RORUTL07 ;HCIOFO/SG - TEST ENTRY POINTS ; 26 May 2015 3:44 PM
;;1.5;CLINICAL CASE REGISTRIES;**21,26**;Feb 17, 2006;Build 53
;
Q
;******************************************************************************
;******************************************************************************
; --- ROUTINE MODIFICATION LOG ---
;
;PKG/PATCH DATE DEVELOPER MODIFICATION
;----------- ---------- ----------- ----------------------------------------
;ROR*1.5*26 APR 2015 T KOPP UPDATE updated to ask for start date
; and set IO variable
;
;******************************************************************************
;******************************************************************************
;
;***** DISPLAYS THE ERRORS
ERROR ;
D DSPSTK^RORERR()
Q
;
;***** DATA EXTRACTION TEST ENTRY POINT
N RORERRDL ; Default error location
N RORERROR ; Error processing data
N RORPARM ; Application parameters
;
N RC,REGLST,REGNAME,SDT
W !,"DATA EXTRACTION & TRANSMISSION IN DEBUG MODE",!
D KILL^XUSCLEAN
S RORPARM("DEBUG")=2
S RORPARM("ERR")=1
D CLEAR^RORERR("EXTRACT^RORUTL07")
;--- Select registries
Q:$$SELREG(.REGLST)'>0
;--- Request a start date
S SDT=$$GETSDT() G:SDT<0 ERROR
;--- Extract the registry data
S RC=$$EXTRACT^ROREXT(.REGLST,SDT,,"S") G:RC<0 ERROR
Q
;
;***** REQESTS A START DATE FROM A USER
;
; Return Values:
; <0 Error Code
; "" No start date (default)
; >0 Start date
;
GETSDT() ;
;;If you enter an empty string then the individual start date
;;(from the registry record) will be used for each patient.
;
N DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,RC,X,Y
S DIR(0)="DO^:DT:EX"
S DIR("A")="Start date for data extraction"
F X=1:1 S Y=$P($T(GETSDT+X),";;",2) Q:Y="" S DIR("?",X)=Y
S DIR("?")="This response must be a date."
D ^DIR
S RC=$S($D(DTOUT):-72,$D(DUOUT):-71,1:0)
Q $S(RC<0:RC,1:$G(Y))
;
;***** SELECTS REGISTRIES FROM THE FILE #798.1
;
; .REGLST Reference to a local variable for the list of
; registry names (subscripts) and IENs (values)
;
; Return Values:
; <0 Error code
; 0 Nothing selected
; >0 Number of selected registries
; "" Timeout or "^"
;
SELREG(REGLST) ;
N CNT,DA,DIC,DLAYGO,DTOUT,DUOUT,X,Y
K REGLST S CNT=0
;--- Select a registry
S DIC=798.1,DIC(0)="AENQ"
S DIC("A")="Select a Registry: "
F D Q:Y'>0 S REGLST($P(Y,U,2))=+Y,CNT=CNT+1
. D ^DIC
W !
Q $S($D(DTOUT)!$D(DUOUT):"",1:CNT)
;
;***** REGISTRY UPDATE TEST ENTRY POINT
UPDATE ;
N RORERRDL ; Default error location
N RORERROR ; Error processing data
N RORPARM ; Application parameters
;
N RC,REGLST,REGNAME,DSBEG
D HOME^%ZIS
W !,"REGISTRY UPDATE IN DEBUG MODE",!
D KILL^XUSCLEAN
S RORPARM("DEBUG")=2
S RORPARM("ERR")=1
D CLEAR^RORERR("UPDATE^RORUTL07")
;--- Select registries
Q:$$SELREG(.REGLST)'>0
;--- Request a start date
S DSBEG=$$GETSDT()
Q:DSBEG<0
;--- Update the registry
S RC=$$UPDATE^RORUPD(.REGLST) G:RC<0 ERROR
Q
;DEFINE ENTRY POINT TO CLEAR AND RESTART REGISTRY UPDATE
DEL(REGLST) ;
;Select new registry to delete
;delete any records in 798 for that registry
;delete enable protocols,hdt,registry updated until
N REGNAME,REGIEN,IEN,DA,DIK,RORFDA,IENS,RORMSG,DIERR
N FILE,ROOT,IX,RORPARM,FLD
S (REGNAME,IEN)=""
S RORPARM("DEVELOPER")=1
F S REGNAME=$O(REGLST(REGNAME)) Q:REGNAME="" D
. S REGIEN=$$REGIEN^RORUTL02(REGNAME) Q:REGIEN=""
. ; Only local registries
. Q:$P($G(^ROR(798.1,REGIEN,0)),U,11)
. S IENS=REGIEN_","
. F FLD=6.1,6.2,7,10,13,13.1,19.1,19.2,19.3,21.01,21.04,21.05 D
. . S RORFDA(798.1,IENS,FLD)="@"
. S RORFDA(798.1,IENS,1)=2850101
. D FILE^DIE(,"RORFDA","RORMSG")
. I $G(DIERR) W !!,"<<ERROR - restoring "_REGNAME_" registry parameters>>" Q
. F S IEN=$O(^RORDATA(798,"AC",REGIEN,IEN)) Q:IEN="" D
. . N DA,DIK
. . S DIK=$$ROOT^DILFD(798),DA=IEN D ^DIK
. . W !,"<< "_IEN_" >> Deleted"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORUTL07 4190 printed Sep 23, 2025@19:20 Page 2
RORUTL07 ;HCIOFO/SG - TEST ENTRY POINTS ; 26 May 2015 3:44 PM
+1 ;;1.5;CLINICAL CASE REGISTRIES;**21,26**;Feb 17, 2006;Build 53
+2 ;
+3 QUIT
+4 ;******************************************************************************
+5 ;******************************************************************************
+6 ; --- ROUTINE MODIFICATION LOG ---
+7 ;
+8 ;PKG/PATCH DATE DEVELOPER MODIFICATION
+9 ;----------- ---------- ----------- ----------------------------------------
+10 ;ROR*1.5*26 APR 2015 T KOPP UPDATE updated to ask for start date
+11 ; and set IO variable
+12 ;
+13 ;******************************************************************************
+14 ;******************************************************************************
+15 ;
+16 ;***** DISPLAYS THE ERRORS
ERROR ;
+1 DO DSPSTK^RORERR()
+2 QUIT
+3 ;
+4 ;***** DATA EXTRACTION TEST ENTRY POINT
+1 ; Default error location
NEW RORERRDL
+2 ; Error processing data
NEW RORERROR
+3 ; Application parameters
NEW RORPARM
+4 ;
+5 NEW RC,REGLST,REGNAME,SDT
+6 WRITE !,"DATA EXTRACTION & TRANSMISSION IN DEBUG MODE",!
+7 DO KILL^XUSCLEAN
+8 SET RORPARM("DEBUG")=2
+9 SET RORPARM("ERR")=1
+10 DO CLEAR^RORERR("EXTRACT^RORUTL07")
+11 ;--- Select registries
+12 if $$SELREG(.REGLST)'>0
QUIT
+13 ;--- Request a start date
+14 SET SDT=$$GETSDT()
if SDT<0
GOTO ERROR
+15 ;--- Extract the registry data
+16 SET RC=$$EXTRACT^ROREXT(.REGLST,SDT,,"S")
if RC<0
GOTO ERROR
+17 QUIT
+18 ;
+19 ;***** REQESTS A START DATE FROM A USER
+20 ;
+21 ; Return Values:
+22 ; <0 Error Code
+23 ; "" No start date (default)
+24 ; >0 Start date
+25 ;
GETSDT() ;
+1 ;;If you enter an empty string then the individual start date
+2 ;;(from the registry record) will be used for each patient.
+3 ;
+4 NEW DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,RC,X,Y
+5 SET DIR(0)="DO^:DT:EX"
+6 SET DIR("A")="Start date for data extraction"
+7 FOR X=1:1
SET Y=$PIECE($TEXT(GETSDT+X),";;",2)
if Y=""
QUIT
SET DIR("?",X)=Y
+8 SET DIR("?")="This response must be a date."
+9 DO ^DIR
+10 SET RC=$SELECT($DATA(DTOUT):-72,$DATA(DUOUT):-71,1:0)
+11 QUIT $SELECT(RC<0:RC,1:$GET(Y))
+12 ;
+13 ;***** SELECTS REGISTRIES FROM THE FILE #798.1
+14 ;
+15 ; .REGLST Reference to a local variable for the list of
+16 ; registry names (subscripts) and IENs (values)
+17 ;
+18 ; Return Values:
+19 ; <0 Error code
+20 ; 0 Nothing selected
+21 ; >0 Number of selected registries
+22 ; "" Timeout or "^"
+23 ;
SELREG(REGLST) ;
+1 NEW CNT,DA,DIC,DLAYGO,DTOUT,DUOUT,X,Y
+2 KILL REGLST
SET CNT=0
+3 ;--- Select a registry
+4 SET DIC=798.1
SET DIC(0)="AENQ"
+5 SET DIC("A")="Select a Registry: "
+6 FOR
Begin DoDot:1
+7 DO ^DIC
End DoDot:1
if Y'>0
QUIT
SET REGLST($PIECE(Y,U,2))=+Y
SET CNT=CNT+1
+8 WRITE !
+9 QUIT $SELECT($DATA(DTOUT)!$DATA(DUOUT):"",1:CNT)
+10 ;
+11 ;***** REGISTRY UPDATE TEST ENTRY POINT
UPDATE ;
+1 ; Default error location
NEW RORERRDL
+2 ; Error processing data
NEW RORERROR
+3 ; Application parameters
NEW RORPARM
+4 ;
+5 NEW RC,REGLST,REGNAME,DSBEG
+6 DO HOME^%ZIS
+7 WRITE !,"REGISTRY UPDATE IN DEBUG MODE",!
+8 DO KILL^XUSCLEAN
+9 SET RORPARM("DEBUG")=2
+10 SET RORPARM("ERR")=1
+11 DO CLEAR^RORERR("UPDATE^RORUTL07")
+12 ;--- Select registries
+13 if $$SELREG(.REGLST)'>0
QUIT
+14 ;--- Request a start date
+15 SET DSBEG=$$GETSDT()
+16 if DSBEG<0
QUIT
+17 ;--- Update the registry
+18 SET RC=$$UPDATE^RORUPD(.REGLST)
if RC<0
GOTO ERROR
+19 QUIT
+20 ;DEFINE ENTRY POINT TO CLEAR AND RESTART REGISTRY UPDATE
DEL(REGLST) ;
+1 ;Select new registry to delete
+2 ;delete any records in 798 for that registry
+3 ;delete enable protocols,hdt,registry updated until
+4 NEW REGNAME,REGIEN,IEN,DA,DIK,RORFDA,IENS,RORMSG,DIERR
+5 NEW FILE,ROOT,IX,RORPARM,FLD
+6 SET (REGNAME,IEN)=""
+7 SET RORPARM("DEVELOPER")=1
+8 FOR
SET REGNAME=$ORDER(REGLST(REGNAME))
if REGNAME=""
QUIT
Begin DoDot:1
+9 SET REGIEN=$$REGIEN^RORUTL02(REGNAME)
if REGIEN=""
QUIT
+10 ; Only local registries
+11 if $PIECE($GET(^ROR(798.1,REGIEN,0)),U,11)
QUIT
+12 SET IENS=REGIEN_","
+13 FOR FLD=6.1,6.2,7,10,13,13.1,19.1,19.2,19.3,21.01,21.04,21.05
Begin DoDot:2
+14 SET RORFDA(798.1,IENS,FLD)="@"
End DoDot:2
+15 SET RORFDA(798.1,IENS,1)=2850101
+16 DO FILE^DIE(,"RORFDA","RORMSG")
+17 IF $GET(DIERR)
WRITE !!,"<<ERROR - restoring "_REGNAME_" registry parameters>>"
QUIT
+18 FOR
SET IEN=$ORDER(^RORDATA(798,"AC",REGIEN,IEN))
if IEN=""
QUIT
Begin DoDot:2
+19 NEW DA,DIK
+20 SET DIK=$$ROOT^DILFD(798)
SET DA=IEN
DO ^DIK
+21 WRITE !,"<< "_IEN_" >> Deleted"
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
