289 lines
8.6 KiB
Mathematica
289 lines
8.6 KiB
Mathematica
RORUTL06 ;HCIOFO/SG - DEVELOPER ENTRY POINTS ; 11/20/05 5:09pm
|
|
;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
|
|
;
|
|
N DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
|
|
W !,"CLINICAL CASE REGISTRIES DEVELOPER'S UTILITIES"
|
|
S X=""
|
|
S X=X_";M:Metadata definitions"
|
|
S X=X_";V:Verify registry definition"
|
|
S X=X_";P:Prepare for KIDS"
|
|
S DIR(0)="SO^"_$P(X,";",2,999)
|
|
D ^DIR W ! Q:$D(DIRUT)
|
|
G PRTMDE:Y="M",VERIFY:Y="V",DISTPREP:Y="P"
|
|
Q
|
|
;
|
|
;***** VERIFIES REGISTRY DEFINITION
|
|
VERIFY ;
|
|
N RORERRDL ; Default error location
|
|
N RORERROR ; Error processing data
|
|
N RORLOG ; Log parameters
|
|
N RORPARM ; Application parameters
|
|
;
|
|
N RC,REGLST,REGNAME,TMP
|
|
W !,"REGISTRY DEFINITION VERIFIER",!
|
|
D KILL^XUSCLEAN,INIT^RORUTL01("ROR")
|
|
S RORPARM("DEBUG")=2
|
|
S RORPARM("ERR")=1
|
|
S RORPARM("LOG")=1
|
|
F TMP=1:1:6 S RORPARM("LOG",TMP)=1
|
|
D CLEAR^RORERR("START^RORUTL06")
|
|
;--- Select registries
|
|
Q:$$SELREG^RORUTL07(.REGLST)'>0
|
|
;--- Validate registry update defintion
|
|
S RC=$$UPDDEF(.REGLST) G:RC<0 ERROR
|
|
;--- Validate data extraction defintion
|
|
S RC=$$EXTDEF(.REGLST) G:RC<0 ERROR
|
|
;--- Cleanup
|
|
D INIT^RORUTL01("ROR")
|
|
Q
|
|
;
|
|
;***** PREPARES THE REGISTRY FOR KIDS DISTRIBUTION
|
|
DISTPREP ;
|
|
N RORERRDL ; Default error location
|
|
N RORERROR ; Error processing data
|
|
N RORFULL ; Full installation (backpull, population, etc.)
|
|
N RORPARM ; Application parameters
|
|
;
|
|
N IENS,FLD,FULL,RC,REGIEN,REGNAME,RORFDA,RORMSG
|
|
N DA,DIR,DIRUT,DTOUT,DUOUT,X,Y
|
|
W !,"REGISTRY PREPARATION FOR KIDS DISTRIBUTION",!
|
|
D KILL^XUSCLEAN
|
|
S RORPARM("ERR")=1
|
|
D CLEAR^RORERR("DISTPREP^RORUTL06")
|
|
;--- Select a registry
|
|
S RC=$$SELREG^RORUTL18(.REGNAME) G:RC<0 ERROR
|
|
Q:RC'>0 S REGIEN=RC
|
|
;--- Select the type of distribution
|
|
K DIR S DIR(0)="S^I:Installation;U:Update",DIR("B")="Update"
|
|
S DIR("A")="Slect the type of distribution"
|
|
D ^DIR Q:$D(DIRUT) W !
|
|
S RORFULL=(Y="I")
|
|
;--- Request a confirmation
|
|
K DIR S DIR(0)="Y",DIR("B")="NO"
|
|
S DIR("A",1)="Some fields of the '"_REGNAME_"' registry parameters"
|
|
S DIR("A",2)="will be cleared to prepare them for KIDS distribution."
|
|
S DIR("A")="Do you really want to do this"
|
|
D ^DIR Q:'$G(Y) W !
|
|
;--- Clear Registry parameters (single-valued)
|
|
S IENS=REGIEN_","
|
|
F FLD=1,2,5,13,19.1,19.2,19.3,21.01,21.04,21.05 D
|
|
. S RORFDA(798.1,IENS,FLD)="@"
|
|
D FILE^DIE(,"RORFDA","RORMSG")
|
|
G:$$DBS^RORERR("RORMSG",-9,,,798.1,IENS) ERROR
|
|
;--- Clear Registry parameters (multiples)
|
|
S IENS=","_REGIEN_","
|
|
G:$$CLEAR^RORUTL05(798.11,IENS)<0 ERROR ; LOG EVENT (8.1)
|
|
G:$$CLEAR^RORUTL05(798.114,IENS)<0 ERROR ; NOTIFICATION (14)
|
|
G:$$CLEAR^RORUTL05(798.122,IENS)<0 ERROR ; LAST BATCH CONTROL ID (22)
|
|
G:$$CLEAR^RORUTL05(798.128,IENS)<0 ERROR ; LOCAL LAB TEST (28)
|
|
G:$$CLEAR^RORUTL05(798.129,IENS)<0 ERROR ; LOCAL DRUG (29)
|
|
G:$$CLEAR^RORUTL05(798.12,IENS)<0 ERROR ; REPORT STATS (30)
|
|
;--- Registry-specific data
|
|
I REGNAME="VA HEPC" G:$$HEPC(REGIEN)<0 ERROR
|
|
I REGNAME="VA HIV" G:$$HIV(REGIEN)<0 ERROR
|
|
;--- Clean the ROR LOCAL FIELD file (#799.53)
|
|
G:$$LOCFLDS()<0 ERROR
|
|
;--- Success
|
|
W !,"Registry parameters are ready for distribution."
|
|
Q
|
|
;
|
|
;***** DISPLAYS THE ERRORS
|
|
ERROR ;
|
|
D DSPSTK^RORERR()
|
|
Q
|
|
;
|
|
;***** VALIDATES DATA EXTRACTION DEFINITION
|
|
;
|
|
; .REGLST Reference to a local array containing
|
|
; registry names as subscripts
|
|
;
|
|
; Return Values:
|
|
; <0 Error Code
|
|
; 0 Ok
|
|
;
|
|
EXTDEF(REGLST) ;
|
|
N RORERRDL ; Default error location
|
|
N ROREXT ; Data extraction descriptor
|
|
N RORHL ; HL7 variables
|
|
N RORLRC ; List of codes of Lab results to be extracted
|
|
;
|
|
N RC
|
|
W !,"DATA EXTRACTION DEFINITION",!
|
|
D CLEAR^RORERR("UPDDEF^RORUTL06")
|
|
S RC=$$PREPARE^ROREXPR(.REGLST)
|
|
D:RC'<0 DEBUG^ROREXTUT
|
|
Q RC
|
|
;
|
|
;***** HEPC-SPECIFIC PREPARATIONS
|
|
HEPC(REGIEN) ;
|
|
N IENS,RORFDA,RORMSG
|
|
S IENS=(+REGIEN)_","
|
|
D:$G(RORFULL)
|
|
. S RORFDA(798.1,IENS,1)=2900101 ; REGISTRY UPDATED UNTIL
|
|
. S RORFDA(798.1,IENS,2)=2850101 ; DATA EXTRACTED UNTIL
|
|
S RORFDA(798.1,IENS,25)=1 ; ENABLE PROTOCOLS
|
|
D FILE^DIE(,"RORFDA","RORMSG")
|
|
Q $$DBS^RORERR("RORMSG",-9,,,798.1,IENS)
|
|
;
|
|
;***** HIV-SPECIFIC PREPARATIONS
|
|
HIV(REGIEN) ;
|
|
N IENS,RORFDA,RORMSG
|
|
S IENS=(+REGIEN)_","
|
|
D:$G(RORFULL)
|
|
. S RORFDA(798.1,IENS,1)=2850101 ; REGISTRY UPDATED UNTIL
|
|
. S RORFDA(798.1,IENS,2)=2850101 ; DATA EXTRACTED UNTIL
|
|
S RORFDA(798.1,IENS,25)=1 ; ENABLE PROTOCOLS
|
|
D FILE^DIE(,"RORFDA","RORMSG")
|
|
Q $$DBS^RORERR("RORMSG",-9,,,798.1,IENS)
|
|
;
|
|
;***** CLEANS THE 'ROR LOCAL FIELD' FILE (#799.53)
|
|
LOCFLDS() ;
|
|
N DA,DIK,ROOT
|
|
S DIK=$$ROOT^DILFD(799.53),ROOT=$$CREF^DILF(DIK)
|
|
S DA=0
|
|
F S DA=$O(@ROOT@(DA)) Q:DA'>0 D ^DIK
|
|
Q 0
|
|
;
|
|
;***** PRINTS THE DATA ELEMENT METADATA
|
|
PRTMDE ;
|
|
N RORCOLS ; Lits of column descriptors
|
|
N RORERRDL ; Default error location
|
|
N RORERROR ; Error processing data
|
|
N RORLST ; List of files grouped by parents
|
|
N RORPAGE ; Current page number
|
|
N RORPARM ; Application parameters
|
|
N RORTTL ; Title of the report
|
|
;
|
|
N DIR,DIRUT,DTOUT,DUOUT,MODE,TMP,X,Y
|
|
D KILL^XUSCLEAN
|
|
S (DDBDMSG,RORTTL)="METADATA OF THE DATA ELEMENTS"
|
|
W !,RORTTL,! S RORPARM("ERR")=1
|
|
D CLEAR^RORERR("PRTMDE^RORUTL06")
|
|
;---Request report sort mode from user
|
|
S DIR(0)="S^H:Hierarhical;L:List of codes"
|
|
S DIR("A")="Sort mode",DIR("B")="List of codes"
|
|
D ^DIR Q:$D(DIRUT) S MODE=Y
|
|
;--- Generate and print the report
|
|
I MODE="H" S RC=0 D
|
|
. N %ZIS,I,FILE,PARENT,ROOT,RORMSG
|
|
. S ROOT=$$ROOT^DILFD(799.2,,1),RORPAGE=0
|
|
. ;--- Load column descriptors
|
|
. F I=1:1 S TMP=$P($T(PRTMDEH+I),";;",2) Q:TMP="" D
|
|
. . S RORCOLS(I)=$TR($P(TMP,U,1,3)," ")_U_$P(TMP,U,4)
|
|
. ;--- Load file list
|
|
. S FILE=0,RC=0
|
|
. F S FILE=$O(@ROOT@(FILE)) Q:FILE'>0 D Q:RC<0
|
|
. . S PARENT=+$$GET1^DIQ(799.2,FILE_",",1,"I",,"RORMSG")
|
|
. . I $G(DIERR) D Q
|
|
. . . S RC=$$DBS^RORERR("RORMSG",-9,,,799.2,FILE_",")
|
|
. . S RORLST(PARENT,FILE)=""
|
|
. Q:RC<0
|
|
. ;--- Print the report
|
|
. S %ZIS("B")=""
|
|
. D ^%ZIS Q:$G(POP) U IO
|
|
. S RC=$$PRTMDEH() S:RC'<0 RC=$$PRTMDE1(0,1)
|
|
. D ^%ZISC
|
|
E S RC=$$PRTMDE2()
|
|
G:RC<0 ERROR
|
|
Q
|
|
;
|
|
;***** PRINTS A LEVEL OF THE "FILE-PROCESSING TREE"
|
|
;
|
|
; PARENT Parent file number
|
|
; LEVEL Number of the current level in the tree
|
|
;
|
|
; Return Values:
|
|
; <0 Error Code
|
|
; 0 Ok
|
|
;
|
|
PRTMDE1(PARENT,LEVEL) ;
|
|
N FIELDS,FILE,FLD,I,IENS,IR,L,RORBUF,RORMSG
|
|
S FIELDS="@;.01E;.02I;1I;2E;4I;4.1;4.2;6I"
|
|
;---
|
|
S FILE="",RC=0
|
|
F S FILE=$O(RORLST(PARENT,FILE)) Q:FILE="" D Q:RC<0
|
|
. ;--- Load descriptors of the data elements
|
|
. K RORBUF S IENS=","_FILE_","
|
|
. D LIST^DIC(799.22,IENS,FIELDS,,,,,"B",,,"RORBUF","RORMSG")
|
|
. ;--- Print header (if necessary) and file number
|
|
. I ($Y+5)>IOSL S RC=$$PRTMDEH() Q:RC<0
|
|
. D PRTMDEL(LEVEL-1),PRTMDEL(LEVEL-1,FILE)
|
|
. ;--- Print data element descriptors
|
|
. S IR="",RC=0
|
|
. F S IR=$O(RORBUF("DILIST","ID",IR)) Q:IR="" D Q:RC<0 W !
|
|
. . I ($Y+5)>IOSL S RC=$$PRTMDEH() Q:RC<0
|
|
. . D:IR>1 PRTMDEL(LEVEL,"")
|
|
. . S I=""
|
|
. . F S I=$O(RORCOLS(I)) Q:I="" D
|
|
. . . S FLD=+$P(RORCOLS(I),U,2) Q:FLD'>0
|
|
. . . S L=+$P(RORCOLS(I),U,3) S:L'>0 L=999
|
|
. . . W ?(+RORCOLS(I)),$E($G(RORBUF("DILIST","ID",IR,FLD)),1,L)
|
|
. Q:RC<0
|
|
. S:$D(RORLST(FILE))>1 RC=$$PRTMDE1(FILE,LEVEL+1)
|
|
Q $S(RC<0:RC,1:0)
|
|
;
|
|
;***** PRINTS A TABLE OF DATA ELEMENTS
|
|
PRTMDE2() ;
|
|
N BY,DHD,FR,L,DIC,FLDS,TO
|
|
S L=0,DIC=799.2,DHD=RORTTL
|
|
S BY="[ROR DATA ELEMENTS]",FLDS="[ROR DATA ELEMENTS]"
|
|
D EN1^DIP
|
|
Q 0
|
|
;
|
|
;***** PRINTS A HEADER OF THE DATA ELEMENT REPORT
|
|
; X Field Width Title
|
|
PRTMDEH() ;
|
|
;; 0^ ^ ^File
|
|
;; 22^ .01^ 25^Data Name
|
|
;; 49^ .02^ ^Code
|
|
;; 55^ 2 ^ ^Req
|
|
;; 60^ 1 ^ ^API
|
|
;; 65^ 6 ^ ^Field Number
|
|
;; 82^ 4 ^ ^VT
|
|
;; 86^ 4.1 ^ 20^External
|
|
;;108^ 4.2 ^ 20^Internal
|
|
;
|
|
N DIR,DIRUT,DTOUT,DUOUT,I,X,Y
|
|
I RORPAGE,$E(IOST,1,2)="C-" D Q:'Y $S(Y="":-72,1:-71)
|
|
. S DIR(0)="E" D ^DIR
|
|
W:RORPAGE!($E(IOST,1,2)="C-") @IOF
|
|
S RORPAGE=RORPAGE+1,I="" W RORTTL,!
|
|
F S I=$O(RORCOLS(I)) Q:I="" W ?(+RORCOLS(I)),$P(RORCOLS(I),U,4)
|
|
S X="",$P(X,"-",IOM)=""
|
|
W !,X,!
|
|
Q 0
|
|
;
|
|
;***** PRINTS THE LEVEL INDICATOR
|
|
;
|
|
; N Number of dots in the indicator
|
|
; [FILE] File number
|
|
;
|
|
PRTMDEL(N,FILE) ;
|
|
N I W:$X>0 ! F I=1:1:N W ". "
|
|
W:$D(FILE) FILE W:'$D(FILE) !
|
|
Q
|
|
;
|
|
;***** VALIDATES REGISTRY UPDATE DEFINITION
|
|
;
|
|
; .REGLST Reference to a local array containing
|
|
; registry names as subscripts
|
|
;
|
|
; Return Values:
|
|
; <0 Error Code
|
|
; 0 Ok
|
|
;
|
|
UPDDEF(REGLST) ;
|
|
N RORERRDL ; Default error location
|
|
N RORLRC ; List of Lab result codes to check
|
|
N RORUPD ; Update descriptor
|
|
N RORUPDPI ; Closed root of the temporary storage
|
|
N RORVALS ; Calculated values
|
|
;
|
|
N RC
|
|
W !,"REGISTRY UPDATE DEFINITION",!
|
|
D CLEAR^RORERR("UPDDEF^RORUTL06")
|
|
S RORUPDPI=$NA(^TMP("RORUPD",$J))
|
|
S RC=$$PREPARE^RORUPR(.REGLST)
|
|
D:RC'<0 DEBUG^RORUPDUT
|
|
Q RC
|