Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDECRTCF2

SDECRTCF2.m

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