- 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 Jan 18, 2025@03:53:49 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 ;