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