SDECRTCF2 ;ALB/LAB- Cleanup of orphaned children of MRTC ;Jun 04,2021@15:23
;;5.3;Scheduling;**788**;Aug 13, 1993;Build 6
;;Per VHA Directive 2004-038, this routine should not be modified
Q
;
CLEANUP ;
N INPID,POP,PIDDATE,DIR,CNT,UPDATE
S POP=0
D VERIFYRUN
D:'POP PRINTORUPDATE
D:'POP DEVICEPROMPT
D:'POP LOOP
D:'POP FIN
Q
;
VERIFYRUN ;display what option does and verify user wants to run
N DIRUT,DIR,X1,X2,X
;
; Entry Point for clean-up with user specified dates
;
S X1=DT,X2=-90 D C^%DTC
S INPID=X
S PIDDATE=$$FMTE^XLFDT($$FMADD^XLFDT(+DT,-90),5)
W !!,"This OPTION will disposition those Return to Clinic Requests (RTC) that are "
W !,"in a status of OPEN when the parent is in a status of closed"
W !!,"Request that have a Patient Identified Date (PID) within the last 90 days "
W !,"("_PIDDATE_") will NOT be selected for cleanup.",!
;
; verify they want to run clean-up
;
W !!
S DIR(0)="Y"
S DIR("A")="Are you sure you would like to run the Stuck MRTC child cleanup tool"
S DIR("?")="Enter 'Y'es or 'N'o."
S DIR("B")="YES"
D ^DIR
G:$G(DIRUT)!(Y=0) EXIT
W !!
DTPROMPT ;prompt for pid to search on
N Y
S DIR(0)="DAO^3170101:"_+INPID_":EX",DIR("A")="Enter a PID before or equal to "_PIDDATE_": ",DIR("B")=PIDDATE ;
S DIR("?",1)="Enter a Patient Identified Date (PID). Requests will be selected that are less than or equal to the entered date.",DIR("?")="The date must be less than or equal to "_PIDDATE ;
D ^DIR
G:+Y<1 EXIT
S INPID=Y
Q
;
DEVICEPROMPT ;prompt for device
D ^%ZIS Q:POP
U IO
W !,"Results from the Stuck MRTC child cleanup tool.",!!
Q
;
PRINTORUPDATE ;does user want to print report only or udpate and print
N Y
W !!
S DIR(0)="Y"
S DIR("A")="Would you like to UPDATE the records? Enter 'N'o to print only."
S DIR("?")="Enter 'Y'es to UPDATE and PRINT the records or 'N'o to print records only."
S DIR("B")="NO"
D ^DIR
G:$G(DIRUT) EXIT
S UPDATE=Y
W !!
Q
;
LOOP ;loop through open requests and cleanup child's status
N SDDT,SDIEN,SDPARENT,SDPARENTINFO,SDFND,RETN,SDPID,SDCHILDINFO
S CNT=0
S SDDT=""
;loop through all open request
F S SDDT=$O(^SDEC(409.85,"E","O",SDDT)) Q:SDDT="" D
. S SDIEN=""
. F S SDIEN=$O(^SDEC(409.85,"E","O",SDDT,SDIEN)) Q:SDIEN="" D
. . Q:$$GET1^DIQ(409.85,SDIEN,41,"E")'="YES" ;Checking to see if this is an MRTC
. . S SDPID=$$GET1^DIQ(409.85,SDIEN,22,"E")
. . Q:$$GET1^DIQ(409.85,SDIEN,22,"I")>INPID ;If PID is less than 90 days old, do not quit.
. . S SDPARENT=$$GET1^DIQ(409.85,SDIEN,43.8,"I")
. . Q:SDPARENT="" ;must be parent quit out if not a child
. . D GETS^DIQ(409.85,SDIEN,".01;21;22;23","IE","SDCHILDINFO")
. . D GETS^DIQ(409.85,SDPARENT,"21;23","IE","SDPARENTINFO")
. . ;if parent was closed by a dispositon other than MRTC PARENT CLOSED,
. . I SDPARENTINFO(409.85,SDPARENT_",",23,"E")="CLOSED" D
. . . D WRITEBEFORE
. . . ; call RPC ARCLOSE with Request IEN, Disposition,DUZ,today's date)
. . . D:UPDATE ARCLOSE^SDEC(.RETN,SDIEN,SDPARENTINFO(409.85,SDPARENT_",",21,"I"),DUZ,$$FMTE^XLFDT(+DT,5))
. . . D:UPDATE WRITEAFTER
Q
WRITEBEFORE ;write information for child and parent that were selected for cleanup
N LAST4,ORDID
S CNT=CNT+1
W !!,"PATIENT = ",SDCHILDINFO(409.85,SDIEN_",",.01,"E")
S LAST4=$$GET1^DIQ(2,SDCHILDINFO(409.85,SDIEN_",",.01,"I"),.09,"E")
W " LAST4 = "_$E(LAST4,6,$L(LAST4))
S ORDID=$$GET1^DIQ(409.85,SDIEN,46,"E")
I ORDID>0 W !,"ORDER ID = "_ORDID_" "_$$GET1^DIQ(100,ORDID,5,"E")
W !,"MRTC PARENT = ",SDPARENT
W !," PARENT STATUS = ",SDPARENTINFO(409.85,SDPARENT_",",23,"E")
W !," PARENT DISPOSITION = ",SDPARENTINFO(409.85,SDPARENT_",",21,"E")
W !,"MRTC CHILD = ",SDIEN
W !,"PID = ",SDPID
W !,"BEFORE:"
W !," CHILD STATUS = ",SDCHILDINFO(409.85,SDIEN_",",23,"E")
W !," CHILD DISPOSITION = ",SDCHILDINFO(409.85,SDIEN_",",21,"E")
Q
WRITEAFTER ;write status and disposition after update
N ORDID
W !,"AFTER:"
S ORDID=$$GET1^DIQ(409.85,SDIEN,46,"E")
I ORDID>0 W !,"ORDER ID = "_ORDID_" "_$$GET1^DIQ(100,ORDID,5,"E")
D GETS^DIQ(409.85,SDIEN,"21;23","IE","SDCHILDINFO")
W !," CHILD STATUS = ",SDCHILDINFO(409.85,SDIEN_",",23,"E")
W !," CHILD DISPOSITION = ",SDCHILDINFO(409.85,SDIEN_",",21,"E"),!!
Q
;
EXIT ;exit without running
S POP=1
W !,"Nothing done."
Q
;
FIN ;Show final results
;
D ^%ZISC
I UPDATE W !!,"Search and clean-up is complete!!!!",!,CNT," requests were updated!"
I 'UPDATE W !!,"Report finished.",!,CNT," requests were selected as needing updated."
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECRTCF2 4606 printed Sep 23, 2025@20:29:07 Page 2
SDECRTCF2 ;ALB/LAB- Cleanup of orphaned children of MRTC ;Jun 04,2021@15:23
+1 ;;5.3;Scheduling;**788**;Aug 13, 1993;Build 6
+2 ;;Per VHA Directive 2004-038, this routine should not be modified
+3 QUIT
+4 ;
CLEANUP ;
+1 NEW INPID,POP,PIDDATE,DIR,CNT,UPDATE
+2 SET POP=0
+3 DO VERIFYRUN
+4 if 'POP
DO PRINTORUPDATE
+5 if 'POP
DO DEVICEPROMPT
+6 if 'POP
DO LOOP
+7 if 'POP
DO FIN
+8 QUIT
+9 ;
VERIFYRUN ;display what option does and verify user wants to run
+1 NEW DIRUT,DIR,X1,X2,X
+2 ;
+3 ; Entry Point for clean-up with user specified dates
+4 ;
+5 SET X1=DT
SET X2=-90
DO C^%DTC
+6 SET INPID=X
+7 SET PIDDATE=$$FMTE^XLFDT($$FMADD^XLFDT(+DT,-90),5)
+8 WRITE !!,"This OPTION will disposition those Return to Clinic Requests (RTC) that are "
+9 WRITE !,"in a status of OPEN when the parent is in a status of closed"
+10 WRITE !!,"Request that have a Patient Identified Date (PID) within the last 90 days "
+11 WRITE !,"("_PIDDATE_") will NOT be selected for cleanup.",!
+12 ;
+13 ; verify they want to run clean-up
+14 ;
+15 WRITE !!
+16 SET DIR(0)="Y"
+17 SET DIR("A")="Are you sure you would like to run the Stuck MRTC child cleanup tool"
+18 SET DIR("?")="Enter 'Y'es or 'N'o."
+19 SET DIR("B")="YES"
+20 DO ^DIR
+21 if $GET(DIRUT)!(Y=0)
GOTO EXIT
+22 WRITE !!
DTPROMPT ;prompt for pid to search on
+1 NEW Y
+2 ;
SET DIR(0)="DAO^3170101:"_+INPID_":EX"
SET DIR("A")="Enter a PID before or equal to "_PIDDATE_": "
SET DIR("B")=PIDDATE
+3 ;
SET DIR("?",1)="Enter a Patient Identified Date (PID). Requests will be selected that are less than or equal to the entered date."
SET DIR("?")="The date must be less than or equal to "_PIDDATE
+4 DO ^DIR
+5 if +Y<1
GOTO EXIT
+6 SET INPID=Y
+7 QUIT
+8 ;
DEVICEPROMPT ;prompt for device
+1 DO ^%ZIS
if POP
QUIT
+2 USE IO
+3 WRITE !,"Results from the Stuck MRTC child cleanup tool.",!!
+4 QUIT
+5 ;
PRINTORUPDATE ;does user want to print report only or udpate and print
+1 NEW Y
+2 WRITE !!
+3 SET DIR(0)="Y"
+4 SET DIR("A")="Would you like to UPDATE the records? Enter 'N'o to print only."
+5 SET DIR("?")="Enter 'Y'es to UPDATE and PRINT the records or 'N'o to print records only."
+6 SET DIR("B")="NO"
+7 DO ^DIR
+8 if $GET(DIRUT)
GOTO EXIT
+9 SET UPDATE=Y
+10 WRITE !!
+11 QUIT
+12 ;
LOOP ;loop through open requests and cleanup child's status
+1 NEW SDDT,SDIEN,SDPARENT,SDPARENTINFO,SDFND,RETN,SDPID,SDCHILDINFO
+2 SET CNT=0
+3 SET SDDT=""
+4 ;loop through all open request
+5 FOR
SET SDDT=$ORDER(^SDEC(409.85,"E","O",SDDT))
if SDDT=""
QUIT
Begin DoDot:1
+6 SET SDIEN=""
+7 FOR
SET SDIEN=$ORDER(^SDEC(409.85,"E","O",SDDT,SDIEN))
if SDIEN=""
QUIT
Begin DoDot:2
+8 ;Checking to see if this is an MRTC
if $$GET1^DIQ(409.85,SDIEN,41,"E")'="YES"
QUIT
+9 SET SDPID=$$GET1^DIQ(409.85,SDIEN,22,"E")
+10 ;If PID is less than 90 days old, do not quit.
if $$GET1^DIQ(409.85,SDIEN,22,"I")>INPID
QUIT
+11 SET SDPARENT=$$GET1^DIQ(409.85,SDIEN,43.8,"I")
+12 ;must be parent quit out if not a child
if SDPARENT=""
QUIT
+13 DO GETS^DIQ(409.85,SDIEN,".01;21;22;23","IE","SDCHILDINFO")
+14 DO GETS^DIQ(409.85,SDPARENT,"21;23","IE","SDPARENTINFO")
+15 ;if parent was closed by a dispositon other than MRTC PARENT CLOSED,
+16 IF SDPARENTINFO(409.85,SDPARENT_",",23,"E")="CLOSED"
Begin DoDot:3
+17 DO WRITEBEFORE
+18 ; call RPC ARCLOSE with Request IEN, Disposition,DUZ,today's date)
+19 if UPDATE
DO ARCLOSE^SDEC(.RETN,SDIEN,SDPARENTINFO(409.85,SDPARENT_",",21,"I"),DUZ,$$FMTE^XLFDT(+DT,5))
+20 if UPDATE
DO WRITEAFTER
End DoDot:3
End DoDot:2
End DoDot:1
+21 QUIT
WRITEBEFORE ;write information for child and parent that were selected for cleanup
+1 NEW LAST4,ORDID
+2 SET CNT=CNT+1
+3 WRITE !!,"PATIENT = ",SDCHILDINFO(409.85,SDIEN_",",.01,"E")
+4 SET LAST4=$$GET1^DIQ(2,SDCHILDINFO(409.85,SDIEN_",",.01,"I"),.09,"E")
+5 WRITE " LAST4 = "_$EXTRACT(LAST4,6,$LENGTH(LAST4))
+6 SET ORDID=$$GET1^DIQ(409.85,SDIEN,46,"E")
+7 IF ORDID>0
WRITE !,"ORDER ID = "_ORDID_" "_$$GET1^DIQ(100,ORDID,5,"E")
+8 WRITE !,"MRTC PARENT = ",SDPARENT
+9 WRITE !," PARENT STATUS = ",SDPARENTINFO(409.85,SDPARENT_",",23,"E")
+10 WRITE !," PARENT DISPOSITION = ",SDPARENTINFO(409.85,SDPARENT_",",21,"E")
+11 WRITE !,"MRTC CHILD = ",SDIEN
+12 WRITE !,"PID = ",SDPID
+13 WRITE !,"BEFORE:"
+14 WRITE !," CHILD STATUS = ",SDCHILDINFO(409.85,SDIEN_",",23,"E")
+15 WRITE !," CHILD DISPOSITION = ",SDCHILDINFO(409.85,SDIEN_",",21,"E")
+16 QUIT
WRITEAFTER ;write status and disposition after update
+1 NEW ORDID
+2 WRITE !,"AFTER:"
+3 SET ORDID=$$GET1^DIQ(409.85,SDIEN,46,"E")
+4 IF ORDID>0
WRITE !,"ORDER ID = "_ORDID_" "_$$GET1^DIQ(100,ORDID,5,"E")
+5 DO GETS^DIQ(409.85,SDIEN,"21;23","IE","SDCHILDINFO")
+6 WRITE !," CHILD STATUS = ",SDCHILDINFO(409.85,SDIEN_",",23,"E")
+7 WRITE !," CHILD DISPOSITION = ",SDCHILDINFO(409.85,SDIEN_",",21,"E"),!!
+8 QUIT
+9 ;
EXIT ;exit without running
+1 SET POP=1
+2 WRITE !,"Nothing done."
+3 QUIT
+4 ;
FIN ;Show final results
+1 ;
+2 DO ^%ZISC
+3 IF UPDATE
WRITE !!,"Search and clean-up is complete!!!!",!,CNT," requests were updated!"
+4 IF 'UPDATE
WRITE !!,"Report finished.",!,CNT," requests were selected as needing updated."
+5 QUIT
+6 ;
