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

SDECRTCF.m

Go to the documentation of this file.
  1. SDECRTCF ;ALB/WTC,LAB - Clean-up of Pending RTC orders with closed SDEC Appt Requests ;Dec 01, 2021@12:00
  1. ;;5.3;Scheduling;**745,785,803**;Aug 13, 1993;Build 10
  1. ;;Per VHA Directive 2004-038, this routine should not be modified
  1. ;
  1. ; Close RTC orders in CPRS if the corresponding order in Appointment Request file (#409.85) was closed (appointment made) or otherwise dispositioned.
  1. ; Based on routine from Ty Phelps.
  1. ;
  1. ; Documented API's and Integration Agreements
  1. ; -------------------------------------------
  1. ; Reference to ^ORD(100.01 in ICR #2638
  1. ; Reference to ^OR(100 in ICR #7156
  1. ; Reference to ^VA(200 in ICR #10060
  1. ; Reference to DEM^VADPT in ICR #10061
  1. Q
  1. ;
  1. BYDATE ;
  1. ;
  1. ; Entry Point for clean-up with user specified dates
  1. ;
  1. N CDT,CNT,DIR,DIROUT,DIRUT,DTOUT,DUOUT,POP,SDEDT,SDSDT,X,Y ;
  1. ;
  1. S CNT=0,POP=0
  1. D START
  1. W !!
  1. S CDT=$$FMTE^XLFDT(+DT,5)
  1. ;
  1. STRTDT ;
  1. ;
  1. W !!,"Selection will be made based off of the create date of the Request",!!
  1. S DIR(0)="DAO^3170101:"_+DT_":EX",DIR("A")="SDEC APPOINTMENT REQUEST CREATE DATE to start selection: ",DIR("B")=$$FMTE^XLFDT($$FMADD^XLFDT(+DT,-30),5) ;
  1. S DIR("?",1)="Enter the CREATE date to start the SDEC APPT REQUEST search.",DIR("?")="The date must be between 1/1/2017 and "_CDT ;
  1. D ^DIR Q:+Y<1 ;
  1. I +Y>0 S SDSDT=Y ;
  1. ;
  1. ENDDT ;
  1. ;
  1. N %
  1. K DIROUT,DIRUT,DTOUT,DUOUT
  1. S (X,Y)="" ;
  1. S DIR(0)="DAO^"_SDSDT_":"_+DT_":EX",DIR("A")="SDEC APPOINTMENT REQUEST CREATE DATE to end selection: ",DIR("B")=$$FMTE^XLFDT(+DT,5) ;
  1. S DIR("?",1)="Enter the CREATE date to stop the SDEC APPT REQUEST search.",DIR("?")="The date must be between "_$$FMTE^XLFDT(SDSDT,5)_" and "_CDT ;
  1. D ^DIR ;
  1. G STRTDT:+$G(DTOUT) ;
  1. Q:+Y<1 ;
  1. I +Y>0 S SDEDT=Y ;
  1. K DIR
  1. S DIR(0)="Y"
  1. S DIR("A")="Are you sure you would like to run the SDEC PENDING RTC clean-up"
  1. S DIR("?")="Enter 'Y'es or 'N'o."
  1. S DIR("B")="YES"
  1. D ^DIR
  1. K DIR
  1. G:$G(DIRUT)!(Y=0) EXIT
  1. D LOOP(SDSDT,SDEDT)
  1. D:POP EXIT Q
  1. D FIN(CNT) ;
  1. Q
  1. ;
  1. FULL ;
  1. ;
  1. ; Perform a full clean-up starting from 1/1/2017
  1. ;
  1. N CNT,POP,SDSDT,SDEDT,%
  1. S POP=0
  1. D START ;
  1. S SDSDT=3170101,SDEDT=999999999,CNT=0 ;
  1. K DIR
  1. W !
  1. S DIR(0)="Y"
  1. S DIR("A")="Are you sure you would like to run the FULL SDEC PENDING RTC clean-up"
  1. S DIR("?")="Enter 'Y'es or 'N'o."
  1. S DIR("B")="YES"
  1. D ^DIR
  1. K DIR
  1. G:$G(DIRUT)!(Y=0) EXIT
  1. D LOOP(SDSDT,SDEDT)
  1. D:POP EXIT Q
  1. D FIN(CNT) ;
  1. Q
  1. ;
  1. LOOP(SDSDT,SDEDT) ;
  1. ;
  1. ; Loop through closed SDEC APPT REQUESTS to complete corresponding RTC Orders
  1. ;
  1. N %H,CMT,CMTE,DTPURG,END,INPUT,ORDIS,ORIEN,ORPENDING,ORSTATUS,SDCDT,SDDISP,SDDISPBY,SDDISPDT,SDEC0,SDECDIS,SDIEN,SDPAR,SDPATIENT,SDRQTYPE,STOP,DFN,VADM ;
  1. N SKIP,SKIPFLG
  1. S POP=0
  1. ;
  1. D ^%ZIS Q:POP
  1. W !!,"Starting search and clean-up...." ;
  1. ;
  1. U IO
  1. W !!,"Orders updated via the Clean-up Tool:",!
  1. ;
  1. S SDCDT=$$FMADD^XLFDT(SDSDT,-1),DTPURG=$$FMADD^XLFDT(+DT,7),END=0 ;
  1. S ORPENDING=+$O(^ORD(100.01,"B","PENDING",0)) ; ICR #2638
  1. S CMT="Orders changed to Completed based on SDEC APPT REQUEST being in status of Closed"
  1. S CMTE="Errors during Orders being changed to Completed based on SDEC APPT REQUEST being in status of Closed"
  1. ;
  1. S ^XTMP("OR PENDING RTC CLEAN-UP-"_$$FMTE^XLFDT(DT),0)=DTPURG_U_+DT_U_CMT ;
  1. ;
  1. ; Loop thru closed SDEC APPT REQUESTS
  1. ;
  1. F S SDCDT=$O(^SDEC(409.85,"E","C",SDCDT)) Q:SDCDT="" D Q:END ;
  1. . I SDCDT>SDEDT S END=1 Q ;
  1. . S SDIEN="" F S SDIEN=$O(^SDEC(409.85,"E","C",SDCDT,SDIEN)) Q:SDIEN="" D ;
  1. .. K INPUT ;
  1. .. S SKIPFLG=0
  1. .. S SDEC0=$G(^SDEC(409.85,SDIEN,0)),SDRQTYPE=$P(SDEC0,U,5) Q:SDRQTYPE'="RTC" ; Skip if not RTC order.
  1. .. ;
  1. .. S ORIEN=+$P($G(^SDEC(409.85,SDIEN,7)),U,1) Q:ORIEN=0 ; Skip if not sourced from CPRS (bad data)
  1. .. S ORSTATUS=$$GET1^DIQ(100,ORIEN,5,"I") ; ICR #7156
  1. .. Q:ORSTATUS'=ORPENDING ; Skip if order is not pending
  1. .. ;
  1. .. S SDECDIS=$G(^SDEC(409.85,SDIEN,"DIS"))
  1. .. S SDPATIENT=+$P(SDEC0,U,1)
  1. .. I SDPATIENT=0 D
  1. .. . S SKIPFLG=SKIPFLG+1
  1. .. . S SKIP(SDIEN,SKIPFLG)="Patient pointer missing (bad data)" ; Skip if patient pointer missing (bad data)
  1. .. ;
  1. .. S SDDISPBY=+$P(SDECDIS,U,2)
  1. .. I SDDISPBY=0 D
  1. .. . S SKIPFLG=SKIPFLG+1
  1. .. . S SKIP(SDIEN,SKIPFLG)="Disposition By field is missing"
  1. .. S SDDISPDT=$P(SDECDIS,U,1)
  1. .. I +SDDISPDT=0 D
  1. .. . S SKIPFLG=SKIPFLG+1 ; Skip if disposition date is missing
  1. .. . S SKIP(SDIEN,SKIPFLG)="Disposition Date field is missing"
  1. .. S SDDISP=$P(SDECDIS,U,3)
  1. .. I SDDISP="" D
  1. .. . S SKIPFLG=SKIPFLG+1 ; Skip if disposition is missing
  1. .. . S SKIP(SDIEN,SKIPFLG)="Disposition field is missing"
  1. .. ;
  1. .. I +$P($G(^SDEC(409.85,SDIEN,3)),U,5) D
  1. .. . S SKIPFLG=SKIPFLG+1
  1. .. . S SKIP(SDIEN,SKIPFLG)="Skipped child request." ; Skip if child request
  1. .. ;
  1. .. Q:SKIPFLG ;skip if any errors
  1. .. ;S ORDIS=$S(SDDISP="SA":0,SDDISP="MC":0,1:1) ;
  1. .. S ORDIS=$S(SDDISP=3:0,SDDISP=9:0,SDDISP="REMOVED/SCHEDULED-ASSIGNED":0,SDDISP="MRTC PARENT CLOSED":0,1:1)
  1. .. ;
  1. .. K VADM S DFN=SDPATIENT D DEM^VADPT ; ICR #10061
  1. .. ;
  1. .. ; For child request, skip if parent closed. I don't think this code will ever apply since child requests are ignored.
  1. .. ;
  1. .. S STOP=0
  1. .. S SDPAR=+$P(^SDEC(409.85,SDIEN,3),U,5) I SDPAR D
  1. .. . I $P($G(^SDEC(409.85,SDPAR,0)),U,17)="C" S STOP=1 Q
  1. .. . ;S INPUT("PARTIAL")=1
  1. .. I STOP=1 Q ;Don't process partials if Parent closed
  1. .. ;
  1. .. ; Send HL7 message to update CPRS order file entry.
  1. .. ;
  1. .. D SDHL7BLD(SDIEN,ORIEN,SDDISPBY,DFN,VADM(1),ORDIS) ;
  1. .. ;
  1. .. ; Store record of entry closed.
  1. .. ;
  1. .. S CNT=CNT+1,^XTMP("OR PENDING RTC CLEAN-UP-"_$$FMTE^XLFDT(DT),$J,ORIEN,0)=SDIEN_U_SDPATIENT_U_SDDISPDT_U_SDDISPBY_U_SDDISP_U_ORSTATUS ;
  1. .. D PRNTCLEAN
  1. ;
  1. I CNT=0 W !," No updates were completed."
  1. D:($D(SKIP)) PRNTSKIP ;print skipped records
  1. Q
  1. ;
  1. START ;Show introductory text
  1. ;
  1. W !!,"This routine will search through existing Closed Return to Clinic",!,"SDEC Appointment Requests with a corresponding Order that is in a",!,"Pending status and update as needed." ;
  1. Q
  1. ;
  1. FIN(CNT) ;Show final results
  1. ;
  1. D ^%ZISC
  1. W !!!!,"Search and clean-up is complete!!!!",!,CNT," Orders were updated!" ;
  1. ;
  1. I CNT>0 W !!,"Orders that are updated will be saved for 7 days in the",!,"^XTMP(""OR PENDING RTC CLEAN-UP"_"-"_$$FMTE^XLFDT(DT)_""","_$J_" global." ;
  1. Q
  1. ;
  1. PRNTSKIP ;Print any IENs that were skipped.
  1. N SDIEN,XINDX
  1. W !!,"*********************************************************************"
  1. W !!,"The following SDEC APPOINTMENT REQUEST IENs were skipped:",!
  1. S SDIEN=""
  1. F S SDIEN=$O(SKIP(SDIEN)) Q:SDIEN="" D
  1. . S XINDX=""
  1. . W !!,"Request IEN "_SDIEN_":"
  1. . F S XINDX=$O(SKIP(SDIEN,XINDX)) Q:XINDX="" D
  1. . . W !," "_$G(SKIP(SDIEN,XINDX))
  1. Q
  1. ;
  1. PRNTCLEAN ;Print information from IENS that were cleaned up
  1. W !!,"Request IEN = "_SDIEN_" Patient = "_VADM(1)_" Clinic = "_$$GET1^DIQ(409.85,SDIEN,8,"E")
  1. W !,"Order IEN = "_ORIEN
  1. W !," Original Order Status = "_$$GET1^DIQ(100.01,ORSTATUS_",",.01,"E")
  1. W !," Order Status After Cleanup = "_$$GET1^DIQ(100,ORIEN,5,"E")
  1. W !,"Request Disposition = "_$$GET1^DIQ(409.85,SDIEN,21,"E")
  1. W !," Disposition Date = "_$$FMTE^XLFDT(SDDISPDT,"1F")
  1. W !," Dispositioned By = "_$$GET1^DIQ(200,SDDISPBY,.01,"E")
  1. W !
  1. Q
  1. ;
  1. EXIT ;Exit without runnign clean up
  1. W !!,"Nothing done."
  1. Q
  1. ;
  1. SDHL7BLD(SDIEN,ORIEN,SDDISPBY,SDPATIENT,PATNAME,ORDIS) ;
  1. ;
  1. ; Build HL7 message to send to CPRS to update order file.
  1. ;
  1. N INPUTS,CLINIC ;
  1. ;
  1. S INPUTS("REQ FILE IEN")=SDIEN ; Appointment request
  1. ;
  1. S INPUTS("CLINIC")=$$GET1^DIQ(409.85,SDIEN,8,"I")_U_$$GET1^DIQ(409.85,SDIEN,8,"E") ;clinic
  1. ;
  1. S INPUTS("COMMENT")="RTC dispositioned by clean up process." ;
  1. ;
  1. S INPUTS("DISPOSITION BY")=SDDISPBY_U_$$GET1^DIQ(200,SDDISPBY,.01,"E") ; Dispositioned by
  1. ;
  1. S INPUTS("DISCONTINUE")=ORDIS ; Disposition
  1. ;
  1. S INPUTS("NUMBER APPT")=1 ;
  1. ;
  1. S INPUTS("ORDER IEN")=ORIEN ; Order file (#100) pointer
  1. ;
  1. S INPUTS("PATIENT")=SDPATIENT_U_PATNAME ; Patient pointer and name
  1. ;
  1. S INPUTS("RTC DATE")=$P(^SDEC(409.85,SDIEN,0),U,16) ; CID
  1. ;
  1. D EN^SDHL7BLD(.INPUTS) ;
  1. Q ;