| [613] | 1 | RORUTL06 ;HCIOFO/SG - DEVELOPER ENTRY POINTS ; 11/20/05 5:09pm
|
|---|
| 2 | ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
|
|---|
| 3 | ;
|
|---|
| 4 | N DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
|
|---|
| 5 | W !,"CLINICAL CASE REGISTRIES DEVELOPER'S UTILITIES"
|
|---|
| 6 | S X=""
|
|---|
| 7 | S X=X_";M:Metadata definitions"
|
|---|
| 8 | S X=X_";V:Verify registry definition"
|
|---|
| 9 | S X=X_";P:Prepare for KIDS"
|
|---|
| 10 | S DIR(0)="SO^"_$P(X,";",2,999)
|
|---|
| 11 | D ^DIR W ! Q:$D(DIRUT)
|
|---|
| 12 | G PRTMDE:Y="M",VERIFY:Y="V",DISTPREP:Y="P"
|
|---|
| 13 | Q
|
|---|
| 14 | ;
|
|---|
| 15 | ;***** VERIFIES REGISTRY DEFINITION
|
|---|
| 16 | VERIFY ;
|
|---|
| 17 | N RORERRDL ; Default error location
|
|---|
| 18 | N RORERROR ; Error processing data
|
|---|
| 19 | N RORLOG ; Log parameters
|
|---|
| 20 | N RORPARM ; Application parameters
|
|---|
| 21 | ;
|
|---|
| 22 | N RC,REGLST,REGNAME,TMP
|
|---|
| 23 | W !,"REGISTRY DEFINITION VERIFIER",!
|
|---|
| 24 | D KILL^XUSCLEAN,INIT^RORUTL01("ROR")
|
|---|
| 25 | S RORPARM("DEBUG")=2
|
|---|
| 26 | S RORPARM("ERR")=1
|
|---|
| 27 | S RORPARM("LOG")=1
|
|---|
| 28 | F TMP=1:1:6 S RORPARM("LOG",TMP)=1
|
|---|
| 29 | D CLEAR^RORERR("START^RORUTL06")
|
|---|
| 30 | ;--- Select registries
|
|---|
| 31 | Q:$$SELREG^RORUTL07(.REGLST)'>0
|
|---|
| 32 | ;--- Validate registry update defintion
|
|---|
| 33 | S RC=$$UPDDEF(.REGLST) G:RC<0 ERROR
|
|---|
| 34 | ;--- Validate data extraction defintion
|
|---|
| 35 | S RC=$$EXTDEF(.REGLST) G:RC<0 ERROR
|
|---|
| 36 | ;--- Cleanup
|
|---|
| 37 | D INIT^RORUTL01("ROR")
|
|---|
| 38 | Q
|
|---|
| 39 | ;
|
|---|
| 40 | ;***** PREPARES THE REGISTRY FOR KIDS DISTRIBUTION
|
|---|
| 41 | DISTPREP ;
|
|---|
| 42 | N RORERRDL ; Default error location
|
|---|
| 43 | N RORERROR ; Error processing data
|
|---|
| 44 | N RORFULL ; Full installation (backpull, population, etc.)
|
|---|
| 45 | N RORPARM ; Application parameters
|
|---|
| 46 | ;
|
|---|
| 47 | N IENS,FLD,FULL,RC,REGIEN,REGNAME,RORFDA,RORMSG
|
|---|
| 48 | N DA,DIR,DIRUT,DTOUT,DUOUT,X,Y
|
|---|
| 49 | W !,"REGISTRY PREPARATION FOR KIDS DISTRIBUTION",!
|
|---|
| 50 | D KILL^XUSCLEAN
|
|---|
| 51 | S RORPARM("ERR")=1
|
|---|
| 52 | D CLEAR^RORERR("DISTPREP^RORUTL06")
|
|---|
| 53 | ;--- Select a registry
|
|---|
| 54 | S RC=$$SELREG^RORUTL18(.REGNAME) G:RC<0 ERROR
|
|---|
| 55 | Q:RC'>0 S REGIEN=RC
|
|---|
| 56 | ;--- Select the type of distribution
|
|---|
| 57 | K DIR S DIR(0)="S^I:Installation;U:Update",DIR("B")="Update"
|
|---|
| 58 | S DIR("A")="Slect the type of distribution"
|
|---|
| 59 | D ^DIR Q:$D(DIRUT) W !
|
|---|
| 60 | S RORFULL=(Y="I")
|
|---|
| 61 | ;--- Request a confirmation
|
|---|
| 62 | K DIR S DIR(0)="Y",DIR("B")="NO"
|
|---|
| 63 | S DIR("A",1)="Some fields of the '"_REGNAME_"' registry parameters"
|
|---|
| 64 | S DIR("A",2)="will be cleared to prepare them for KIDS distribution."
|
|---|
| 65 | S DIR("A")="Do you really want to do this"
|
|---|
| 66 | D ^DIR Q:'$G(Y) W !
|
|---|
| 67 | ;--- Clear Registry parameters (single-valued)
|
|---|
| 68 | S IENS=REGIEN_","
|
|---|
| 69 | F FLD=1,2,5,13,19.1,19.2,19.3,21.01,21.04,21.05 D
|
|---|
| 70 | . S RORFDA(798.1,IENS,FLD)="@"
|
|---|
| 71 | D FILE^DIE(,"RORFDA","RORMSG")
|
|---|
| 72 | G:$$DBS^RORERR("RORMSG",-9,,,798.1,IENS) ERROR
|
|---|
| 73 | ;--- Clear Registry parameters (multiples)
|
|---|
| 74 | S IENS=","_REGIEN_","
|
|---|
| 75 | G:$$CLEAR^RORUTL05(798.11,IENS)<0 ERROR ; LOG EVENT (8.1)
|
|---|
| 76 | G:$$CLEAR^RORUTL05(798.114,IENS)<0 ERROR ; NOTIFICATION (14)
|
|---|
| 77 | G:$$CLEAR^RORUTL05(798.122,IENS)<0 ERROR ; LAST BATCH CONTROL ID (22)
|
|---|
| 78 | G:$$CLEAR^RORUTL05(798.128,IENS)<0 ERROR ; LOCAL LAB TEST (28)
|
|---|
| 79 | G:$$CLEAR^RORUTL05(798.129,IENS)<0 ERROR ; LOCAL DRUG (29)
|
|---|
| 80 | G:$$CLEAR^RORUTL05(798.12,IENS)<0 ERROR ; REPORT STATS (30)
|
|---|
| 81 | ;--- Registry-specific data
|
|---|
| 82 | I REGNAME="VA HEPC" G:$$HEPC(REGIEN)<0 ERROR
|
|---|
| 83 | I REGNAME="VA HIV" G:$$HIV(REGIEN)<0 ERROR
|
|---|
| 84 | ;--- Clean the ROR LOCAL FIELD file (#799.53)
|
|---|
| 85 | G:$$LOCFLDS()<0 ERROR
|
|---|
| 86 | ;--- Success
|
|---|
| 87 | W !,"Registry parameters are ready for distribution."
|
|---|
| 88 | Q
|
|---|
| 89 | ;
|
|---|
| 90 | ;***** DISPLAYS THE ERRORS
|
|---|
| 91 | ERROR ;
|
|---|
| 92 | D DSPSTK^RORERR()
|
|---|
| 93 | Q
|
|---|
| 94 | ;
|
|---|
| 95 | ;***** VALIDATES DATA EXTRACTION DEFINITION
|
|---|
| 96 | ;
|
|---|
| 97 | ; .REGLST Reference to a local array containing
|
|---|
| 98 | ; registry names as subscripts
|
|---|
| 99 | ;
|
|---|
| 100 | ; Return Values:
|
|---|
| 101 | ; <0 Error Code
|
|---|
| 102 | ; 0 Ok
|
|---|
| 103 | ;
|
|---|
| 104 | EXTDEF(REGLST) ;
|
|---|
| 105 | N RORERRDL ; Default error location
|
|---|
| 106 | N ROREXT ; Data extraction descriptor
|
|---|
| 107 | N RORHL ; HL7 variables
|
|---|
| 108 | N RORLRC ; List of codes of Lab results to be extracted
|
|---|
| 109 | ;
|
|---|
| 110 | N RC
|
|---|
| 111 | W !,"DATA EXTRACTION DEFINITION",!
|
|---|
| 112 | D CLEAR^RORERR("UPDDEF^RORUTL06")
|
|---|
| 113 | S RC=$$PREPARE^ROREXPR(.REGLST)
|
|---|
| 114 | D:RC'<0 DEBUG^ROREXTUT
|
|---|
| 115 | Q RC
|
|---|
| 116 | ;
|
|---|
| 117 | ;***** HEPC-SPECIFIC PREPARATIONS
|
|---|
| 118 | HEPC(REGIEN) ;
|
|---|
| 119 | N IENS,RORFDA,RORMSG
|
|---|
| 120 | S IENS=(+REGIEN)_","
|
|---|
| 121 | D:$G(RORFULL)
|
|---|
| 122 | . S RORFDA(798.1,IENS,1)=2900101 ; REGISTRY UPDATED UNTIL
|
|---|
| 123 | . S RORFDA(798.1,IENS,2)=2850101 ; DATA EXTRACTED UNTIL
|
|---|
| 124 | S RORFDA(798.1,IENS,25)=1 ; ENABLE PROTOCOLS
|
|---|
| 125 | D FILE^DIE(,"RORFDA","RORMSG")
|
|---|
| 126 | Q $$DBS^RORERR("RORMSG",-9,,,798.1,IENS)
|
|---|
| 127 | ;
|
|---|
| 128 | ;***** HIV-SPECIFIC PREPARATIONS
|
|---|
| 129 | HIV(REGIEN) ;
|
|---|
| 130 | N IENS,RORFDA,RORMSG
|
|---|
| 131 | S IENS=(+REGIEN)_","
|
|---|
| 132 | D:$G(RORFULL)
|
|---|
| 133 | . S RORFDA(798.1,IENS,1)=2850101 ; REGISTRY UPDATED UNTIL
|
|---|
| 134 | . S RORFDA(798.1,IENS,2)=2850101 ; DATA EXTRACTED UNTIL
|
|---|
| 135 | S RORFDA(798.1,IENS,25)=1 ; ENABLE PROTOCOLS
|
|---|
| 136 | D FILE^DIE(,"RORFDA","RORMSG")
|
|---|
| 137 | Q $$DBS^RORERR("RORMSG",-9,,,798.1,IENS)
|
|---|
| 138 | ;
|
|---|
| 139 | ;***** CLEANS THE 'ROR LOCAL FIELD' FILE (#799.53)
|
|---|
| 140 | LOCFLDS() ;
|
|---|
| 141 | N DA,DIK,ROOT
|
|---|
| 142 | S DIK=$$ROOT^DILFD(799.53),ROOT=$$CREF^DILF(DIK)
|
|---|
| 143 | S DA=0
|
|---|
| 144 | F S DA=$O(@ROOT@(DA)) Q:DA'>0 D ^DIK
|
|---|
| 145 | Q 0
|
|---|
| 146 | ;
|
|---|
| 147 | ;***** PRINTS THE DATA ELEMENT METADATA
|
|---|
| 148 | PRTMDE ;
|
|---|
| 149 | N RORCOLS ; Lits of column descriptors
|
|---|
| 150 | N RORERRDL ; Default error location
|
|---|
| 151 | N RORERROR ; Error processing data
|
|---|
| 152 | N RORLST ; List of files grouped by parents
|
|---|
| 153 | N RORPAGE ; Current page number
|
|---|
| 154 | N RORPARM ; Application parameters
|
|---|
| 155 | N RORTTL ; Title of the report
|
|---|
| 156 | ;
|
|---|
| 157 | N DIR,DIRUT,DTOUT,DUOUT,MODE,TMP,X,Y
|
|---|
| 158 | D KILL^XUSCLEAN
|
|---|
| 159 | S (DDBDMSG,RORTTL)="METADATA OF THE DATA ELEMENTS"
|
|---|
| 160 | W !,RORTTL,! S RORPARM("ERR")=1
|
|---|
| 161 | D CLEAR^RORERR("PRTMDE^RORUTL06")
|
|---|
| 162 | ;---Request report sort mode from user
|
|---|
| 163 | S DIR(0)="S^H:Hierarhical;L:List of codes"
|
|---|
| 164 | S DIR("A")="Sort mode",DIR("B")="List of codes"
|
|---|
| 165 | D ^DIR Q:$D(DIRUT) S MODE=Y
|
|---|
| 166 | ;--- Generate and print the report
|
|---|
| 167 | I MODE="H" S RC=0 D
|
|---|
| 168 | . N %ZIS,I,FILE,PARENT,ROOT,RORMSG
|
|---|
| 169 | . S ROOT=$$ROOT^DILFD(799.2,,1),RORPAGE=0
|
|---|
| 170 | . ;--- Load column descriptors
|
|---|
| 171 | . F I=1:1 S TMP=$P($T(PRTMDEH+I),";;",2) Q:TMP="" D
|
|---|
| 172 | . . S RORCOLS(I)=$TR($P(TMP,U,1,3)," ")_U_$P(TMP,U,4)
|
|---|
| 173 | . ;--- Load file list
|
|---|
| 174 | . S FILE=0,RC=0
|
|---|
| 175 | . F S FILE=$O(@ROOT@(FILE)) Q:FILE'>0 D Q:RC<0
|
|---|
| 176 | . . S PARENT=+$$GET1^DIQ(799.2,FILE_",",1,"I",,"RORMSG")
|
|---|
| 177 | . . I $G(DIERR) D Q
|
|---|
| 178 | . . . S RC=$$DBS^RORERR("RORMSG",-9,,,799.2,FILE_",")
|
|---|
| 179 | . . S RORLST(PARENT,FILE)=""
|
|---|
| 180 | . Q:RC<0
|
|---|
| 181 | . ;--- Print the report
|
|---|
| 182 | . S %ZIS("B")=""
|
|---|
| 183 | . D ^%ZIS Q:$G(POP) U IO
|
|---|
| 184 | . S RC=$$PRTMDEH() S:RC'<0 RC=$$PRTMDE1(0,1)
|
|---|
| 185 | . D ^%ZISC
|
|---|
| 186 | E S RC=$$PRTMDE2()
|
|---|
| 187 | G:RC<0 ERROR
|
|---|
| 188 | Q
|
|---|
| 189 | ;
|
|---|
| 190 | ;***** PRINTS A LEVEL OF THE "FILE-PROCESSING TREE"
|
|---|
| 191 | ;
|
|---|
| 192 | ; PARENT Parent file number
|
|---|
| 193 | ; LEVEL Number of the current level in the tree
|
|---|
| 194 | ;
|
|---|
| 195 | ; Return Values:
|
|---|
| 196 | ; <0 Error Code
|
|---|
| 197 | ; 0 Ok
|
|---|
| 198 | ;
|
|---|
| 199 | PRTMDE1(PARENT,LEVEL) ;
|
|---|
| 200 | N FIELDS,FILE,FLD,I,IENS,IR,L,RORBUF,RORMSG
|
|---|
| 201 | S FIELDS="@;.01E;.02I;1I;2E;4I;4.1;4.2;6I"
|
|---|
| 202 | ;---
|
|---|
| 203 | S FILE="",RC=0
|
|---|
| 204 | F S FILE=$O(RORLST(PARENT,FILE)) Q:FILE="" D Q:RC<0
|
|---|
| 205 | . ;--- Load descriptors of the data elements
|
|---|
| 206 | . K RORBUF S IENS=","_FILE_","
|
|---|
| 207 | . D LIST^DIC(799.22,IENS,FIELDS,,,,,"B",,,"RORBUF","RORMSG")
|
|---|
| 208 | . ;--- Print header (if necessary) and file number
|
|---|
| 209 | . I ($Y+5)>IOSL S RC=$$PRTMDEH() Q:RC<0
|
|---|
| 210 | . D PRTMDEL(LEVEL-1),PRTMDEL(LEVEL-1,FILE)
|
|---|
| 211 | . ;--- Print data element descriptors
|
|---|
| 212 | . S IR="",RC=0
|
|---|
| 213 | . F S IR=$O(RORBUF("DILIST","ID",IR)) Q:IR="" D Q:RC<0 W !
|
|---|
| 214 | . . I ($Y+5)>IOSL S RC=$$PRTMDEH() Q:RC<0
|
|---|
| 215 | . . D:IR>1 PRTMDEL(LEVEL,"")
|
|---|
| 216 | . . S I=""
|
|---|
| 217 | . . F S I=$O(RORCOLS(I)) Q:I="" D
|
|---|
| 218 | . . . S FLD=+$P(RORCOLS(I),U,2) Q:FLD'>0
|
|---|
| 219 | . . . S L=+$P(RORCOLS(I),U,3) S:L'>0 L=999
|
|---|
| 220 | . . . W ?(+RORCOLS(I)),$E($G(RORBUF("DILIST","ID",IR,FLD)),1,L)
|
|---|
| 221 | . Q:RC<0
|
|---|
| 222 | . S:$D(RORLST(FILE))>1 RC=$$PRTMDE1(FILE,LEVEL+1)
|
|---|
| 223 | Q $S(RC<0:RC,1:0)
|
|---|
| 224 | ;
|
|---|
| 225 | ;***** PRINTS A TABLE OF DATA ELEMENTS
|
|---|
| 226 | PRTMDE2() ;
|
|---|
| 227 | N BY,DHD,FR,L,DIC,FLDS,TO
|
|---|
| 228 | S L=0,DIC=799.2,DHD=RORTTL
|
|---|
| 229 | S BY="[ROR DATA ELEMENTS]",FLDS="[ROR DATA ELEMENTS]"
|
|---|
| 230 | D EN1^DIP
|
|---|
| 231 | Q 0
|
|---|
| 232 | ;
|
|---|
| 233 | ;***** PRINTS A HEADER OF THE DATA ELEMENT REPORT
|
|---|
| 234 | ; X Field Width Title
|
|---|
| 235 | PRTMDEH() ;
|
|---|
| 236 | ;; 0^ ^ ^File
|
|---|
| 237 | ;; 22^ .01^ 25^Data Name
|
|---|
| 238 | ;; 49^ .02^ ^Code
|
|---|
| 239 | ;; 55^ 2 ^ ^Req
|
|---|
| 240 | ;; 60^ 1 ^ ^API
|
|---|
| 241 | ;; 65^ 6 ^ ^Field Number
|
|---|
| 242 | ;; 82^ 4 ^ ^VT
|
|---|
| 243 | ;; 86^ 4.1 ^ 20^External
|
|---|
| 244 | ;;108^ 4.2 ^ 20^Internal
|
|---|
| 245 | ;
|
|---|
| 246 | N DIR,DIRUT,DTOUT,DUOUT,I,X,Y
|
|---|
| 247 | I RORPAGE,$E(IOST,1,2)="C-" D Q:'Y $S(Y="":-72,1:-71)
|
|---|
| 248 | . S DIR(0)="E" D ^DIR
|
|---|
| 249 | W:RORPAGE!($E(IOST,1,2)="C-") @IOF
|
|---|
| 250 | S RORPAGE=RORPAGE+1,I="" W RORTTL,!
|
|---|
| 251 | F S I=$O(RORCOLS(I)) Q:I="" W ?(+RORCOLS(I)),$P(RORCOLS(I),U,4)
|
|---|
| 252 | S X="",$P(X,"-",IOM)=""
|
|---|
| 253 | W !,X,!
|
|---|
| 254 | Q 0
|
|---|
| 255 | ;
|
|---|
| 256 | ;***** PRINTS THE LEVEL INDICATOR
|
|---|
| 257 | ;
|
|---|
| 258 | ; N Number of dots in the indicator
|
|---|
| 259 | ; [FILE] File number
|
|---|
| 260 | ;
|
|---|
| 261 | PRTMDEL(N,FILE) ;
|
|---|
| 262 | N I W:$X>0 ! F I=1:1:N W ". "
|
|---|
| 263 | W:$D(FILE) FILE W:'$D(FILE) !
|
|---|
| 264 | Q
|
|---|
| 265 | ;
|
|---|
| 266 | ;***** VALIDATES REGISTRY UPDATE DEFINITION
|
|---|
| 267 | ;
|
|---|
| 268 | ; .REGLST Reference to a local array containing
|
|---|
| 269 | ; registry names as subscripts
|
|---|
| 270 | ;
|
|---|
| 271 | ; Return Values:
|
|---|
| 272 | ; <0 Error Code
|
|---|
| 273 | ; 0 Ok
|
|---|
| 274 | ;
|
|---|
| 275 | UPDDEF(REGLST) ;
|
|---|
| 276 | N RORERRDL ; Default error location
|
|---|
| 277 | N RORLRC ; List of Lab result codes to check
|
|---|
| 278 | N RORUPD ; Update descriptor
|
|---|
| 279 | N RORUPDPI ; Closed root of the temporary storage
|
|---|
| 280 | N RORVALS ; Calculated values
|
|---|
| 281 | ;
|
|---|
| 282 | N RC
|
|---|
| 283 | W !,"REGISTRY UPDATE DEFINITION",!
|
|---|
| 284 | D CLEAR^RORERR("UPDDEF^RORUTL06")
|
|---|
| 285 | S RORUPDPI=$NA(^TMP("RORUPD",$J))
|
|---|
| 286 | S RC=$$PREPARE^RORUPR(.REGLST)
|
|---|
| 287 | D:RC'<0 DEBUG^RORUPDUT
|
|---|
| 288 | Q RC
|
|---|
