- SDECRTCF ;ALB/WTC,LAB - Clean-up of Pending RTC orders with closed SDEC Appt Requests ;Dec 01, 2021@12:00
- ;;5.3;Scheduling;**745,785,803**;Aug 13, 1993;Build 10
- ;;Per VHA Directive 2004-038, this routine should not be modified
- ;
- ; Close RTC orders in CPRS if the corresponding order in Appointment Request file (#409.85) was closed (appointment made) or otherwise dispositioned.
- ; Based on routine from Ty Phelps.
- ;
- ; Documented API's and Integration Agreements
- ; -------------------------------------------
- ; Reference to ^ORD(100.01 in ICR #2638
- ; Reference to ^OR(100 in ICR #7156
- ; Reference to ^VA(200 in ICR #10060
- ; Reference to DEM^VADPT in ICR #10061
- Q
- ;
- BYDATE ;
- ;
- ; Entry Point for clean-up with user specified dates
- ;
- N CDT,CNT,DIR,DIROUT,DIRUT,DTOUT,DUOUT,POP,SDEDT,SDSDT,X,Y ;
- ;
- S CNT=0,POP=0
- D START
- W !!
- S CDT=$$FMTE^XLFDT(+DT,5)
- ;
- STRTDT ;
- ;
- W !!,"Selection will be made based off of the create date of the Request",!!
- 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) ;
- 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 ;
- D ^DIR Q:+Y<1 ;
- I +Y>0 S SDSDT=Y ;
- ;
- ENDDT ;
- ;
- N %
- K DIROUT,DIRUT,DTOUT,DUOUT
- S (X,Y)="" ;
- S DIR(0)="DAO^"_SDSDT_":"_+DT_":EX",DIR("A")="SDEC APPOINTMENT REQUEST CREATE DATE to end selection: ",DIR("B")=$$FMTE^XLFDT(+DT,5) ;
- 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 ;
- D ^DIR ;
- G STRTDT:+$G(DTOUT) ;
- Q:+Y<1 ;
- I +Y>0 S SDEDT=Y ;
- K DIR
- S DIR(0)="Y"
- S DIR("A")="Are you sure you would like to run the SDEC PENDING RTC clean-up"
- S DIR("?")="Enter 'Y'es or 'N'o."
- S DIR("B")="YES"
- D ^DIR
- K DIR
- G:$G(DIRUT)!(Y=0) EXIT
- D LOOP(SDSDT,SDEDT)
- D:POP EXIT Q
- D FIN(CNT) ;
- Q
- ;
- FULL ;
- ;
- ; Perform a full clean-up starting from 1/1/2017
- ;
- N CNT,POP,SDSDT,SDEDT,%
- S POP=0
- D START ;
- S SDSDT=3170101,SDEDT=999999999,CNT=0 ;
- K DIR
- W !
- S DIR(0)="Y"
- S DIR("A")="Are you sure you would like to run the FULL SDEC PENDING RTC clean-up"
- S DIR("?")="Enter 'Y'es or 'N'o."
- S DIR("B")="YES"
- D ^DIR
- K DIR
- G:$G(DIRUT)!(Y=0) EXIT
- D LOOP(SDSDT,SDEDT)
- D:POP EXIT Q
- D FIN(CNT) ;
- Q
- ;
- LOOP(SDSDT,SDEDT) ;
- ;
- ; Loop through closed SDEC APPT REQUESTS to complete corresponding RTC Orders
- ;
- N %H,CMT,CMTE,DTPURG,END,INPUT,ORDIS,ORIEN,ORPENDING,ORSTATUS,SDCDT,SDDISP,SDDISPBY,SDDISPDT,SDEC0,SDECDIS,SDIEN,SDPAR,SDPATIENT,SDRQTYPE,STOP,DFN,VADM ;
- N SKIP,SKIPFLG
- S POP=0
- ;
- D ^%ZIS Q:POP
- W !!,"Starting search and clean-up...." ;
- ;
- U IO
- W !!,"Orders updated via the Clean-up Tool:",!
- ;
- S SDCDT=$$FMADD^XLFDT(SDSDT,-1),DTPURG=$$FMADD^XLFDT(+DT,7),END=0 ;
- S ORPENDING=+$O(^ORD(100.01,"B","PENDING",0)) ; ICR #2638
- S CMT="Orders changed to Completed based on SDEC APPT REQUEST being in status of Closed"
- S CMTE="Errors during Orders being changed to Completed based on SDEC APPT REQUEST being in status of Closed"
- ;
- S ^XTMP("OR PENDING RTC CLEAN-UP-"_$$FMTE^XLFDT(DT),0)=DTPURG_U_+DT_U_CMT ;
- ;
- ; Loop thru closed SDEC APPT REQUESTS
- ;
- F S SDCDT=$O(^SDEC(409.85,"E","C",SDCDT)) Q:SDCDT="" D Q:END ;
- . I SDCDT>SDEDT S END=1 Q ;
- . S SDIEN="" F S SDIEN=$O(^SDEC(409.85,"E","C",SDCDT,SDIEN)) Q:SDIEN="" D ;
- .. K INPUT ;
- .. S SKIPFLG=0
- .. S SDEC0=$G(^SDEC(409.85,SDIEN,0)),SDRQTYPE=$P(SDEC0,U,5) Q:SDRQTYPE'="RTC" ; Skip if not RTC order.
- .. ;
- .. S ORIEN=+$P($G(^SDEC(409.85,SDIEN,7)),U,1) Q:ORIEN=0 ; Skip if not sourced from CPRS (bad data)
- .. S ORSTATUS=$$GET1^DIQ(100,ORIEN,5,"I") ; ICR #7156
- .. Q:ORSTATUS'=ORPENDING ; Skip if order is not pending
- .. ;
- .. S SDECDIS=$G(^SDEC(409.85,SDIEN,"DIS"))
- .. S SDPATIENT=+$P(SDEC0,U,1)
- .. I SDPATIENT=0 D
- .. . S SKIPFLG=SKIPFLG+1
- .. . S SKIP(SDIEN,SKIPFLG)="Patient pointer missing (bad data)" ; Skip if patient pointer missing (bad data)
- .. ;
- .. S SDDISPBY=+$P(SDECDIS,U,2)
- .. I SDDISPBY=0 D
- .. . S SKIPFLG=SKIPFLG+1
- .. . S SKIP(SDIEN,SKIPFLG)="Disposition By field is missing"
- .. S SDDISPDT=$P(SDECDIS,U,1)
- .. I +SDDISPDT=0 D
- .. . S SKIPFLG=SKIPFLG+1 ; Skip if disposition date is missing
- .. . S SKIP(SDIEN,SKIPFLG)="Disposition Date field is missing"
- .. S SDDISP=$P(SDECDIS,U,3)
- .. I SDDISP="" D
- .. . S SKIPFLG=SKIPFLG+1 ; Skip if disposition is missing
- .. . S SKIP(SDIEN,SKIPFLG)="Disposition field is missing"
- .. ;
- .. I +$P($G(^SDEC(409.85,SDIEN,3)),U,5) D
- .. . S SKIPFLG=SKIPFLG+1
- .. . S SKIP(SDIEN,SKIPFLG)="Skipped child request." ; Skip if child request
- .. ;
- .. Q:SKIPFLG ;skip if any errors
- .. ;S ORDIS=$S(SDDISP="SA":0,SDDISP="MC":0,1:1) ;
- .. S ORDIS=$S(SDDISP=3:0,SDDISP=9:0,SDDISP="REMOVED/SCHEDULED-ASSIGNED":0,SDDISP="MRTC PARENT CLOSED":0,1:1)
- .. ;
- .. K VADM S DFN=SDPATIENT D DEM^VADPT ; ICR #10061
- .. ;
- .. ; For child request, skip if parent closed. I don't think this code will ever apply since child requests are ignored.
- .. ;
- .. S STOP=0
- .. S SDPAR=+$P(^SDEC(409.85,SDIEN,3),U,5) I SDPAR D
- .. . I $P($G(^SDEC(409.85,SDPAR,0)),U,17)="C" S STOP=1 Q
- .. . ;S INPUT("PARTIAL")=1
- .. I STOP=1 Q ;Don't process partials if Parent closed
- .. ;
- .. ; Send HL7 message to update CPRS order file entry.
- .. ;
- .. D SDHL7BLD(SDIEN,ORIEN,SDDISPBY,DFN,VADM(1),ORDIS) ;
- .. ;
- .. ; Store record of entry closed.
- .. ;
- .. 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 ;
- .. D PRNTCLEAN
- ;
- I CNT=0 W !," No updates were completed."
- D:($D(SKIP)) PRNTSKIP ;print skipped records
- Q
- ;
- START ;Show introductory text
- ;
- 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." ;
- Q
- ;
- FIN(CNT) ;Show final results
- ;
- D ^%ZISC
- W !!!!,"Search and clean-up is complete!!!!",!,CNT," Orders were updated!" ;
- ;
- 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." ;
- Q
- ;
- PRNTSKIP ;Print any IENs that were skipped.
- N SDIEN,XINDX
- W !!,"*********************************************************************"
- W !!,"The following SDEC APPOINTMENT REQUEST IENs were skipped:",!
- S SDIEN=""
- F S SDIEN=$O(SKIP(SDIEN)) Q:SDIEN="" D
- . S XINDX=""
- . W !!,"Request IEN "_SDIEN_":"
- . F S XINDX=$O(SKIP(SDIEN,XINDX)) Q:XINDX="" D
- . . W !," "_$G(SKIP(SDIEN,XINDX))
- Q
- ;
- PRNTCLEAN ;Print information from IENS that were cleaned up
- W !!,"Request IEN = "_SDIEN_" Patient = "_VADM(1)_" Clinic = "_$$GET1^DIQ(409.85,SDIEN,8,"E")
- W !,"Order IEN = "_ORIEN
- W !," Original Order Status = "_$$GET1^DIQ(100.01,ORSTATUS_",",.01,"E")
- W !," Order Status After Cleanup = "_$$GET1^DIQ(100,ORIEN,5,"E")
- W !,"Request Disposition = "_$$GET1^DIQ(409.85,SDIEN,21,"E")
- W !," Disposition Date = "_$$FMTE^XLFDT(SDDISPDT,"1F")
- W !," Dispositioned By = "_$$GET1^DIQ(200,SDDISPBY,.01,"E")
- W !
- Q
- ;
- EXIT ;Exit without runnign clean up
- W !!,"Nothing done."
- Q
- ;
- SDHL7BLD(SDIEN,ORIEN,SDDISPBY,SDPATIENT,PATNAME,ORDIS) ;
- ;
- ; Build HL7 message to send to CPRS to update order file.
- ;
- N INPUTS,CLINIC ;
- ;
- S INPUTS("REQ FILE IEN")=SDIEN ; Appointment request
- ;
- S INPUTS("CLINIC")=$$GET1^DIQ(409.85,SDIEN,8,"I")_U_$$GET1^DIQ(409.85,SDIEN,8,"E") ;clinic
- ;
- S INPUTS("COMMENT")="RTC dispositioned by clean up process." ;
- ;
- S INPUTS("DISPOSITION BY")=SDDISPBY_U_$$GET1^DIQ(200,SDDISPBY,.01,"E") ; Dispositioned by
- ;
- S INPUTS("DISCONTINUE")=ORDIS ; Disposition
- ;
- S INPUTS("NUMBER APPT")=1 ;
- ;
- S INPUTS("ORDER IEN")=ORIEN ; Order file (#100) pointer
- ;
- S INPUTS("PATIENT")=SDPATIENT_U_PATNAME ; Patient pointer and name
- ;
- S INPUTS("RTC DATE")=$P(^SDEC(409.85,SDIEN,0),U,16) ; CID
- ;
- D EN^SDHL7BLD(.INPUTS) ;
- Q ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECRTCF 8185 printed Jan 18, 2025@03:53:48 Page 2
- 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
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified
- +3 ;
- +4 ; Close RTC orders in CPRS if the corresponding order in Appointment Request file (#409.85) was closed (appointment made) or otherwise dispositioned.
- +5 ; Based on routine from Ty Phelps.
- +6 ;
- +7 ; Documented API's and Integration Agreements
- +8 ; -------------------------------------------
- +9 ; Reference to ^ORD(100.01 in ICR #2638
- +10 ; Reference to ^OR(100 in ICR #7156
- +11 ; Reference to ^VA(200 in ICR #10060
- +12 ; Reference to DEM^VADPT in ICR #10061
- +13 QUIT
- +14 ;
- BYDATE ;
- +1 ;
- +2 ; Entry Point for clean-up with user specified dates
- +3 ;
- +4 ;
- NEW CDT,CNT,DIR,DIROUT,DIRUT,DTOUT,DUOUT,POP,SDEDT,SDSDT,X,Y
- +5 ;
- +6 SET CNT=0
- SET POP=0
- +7 DO START
- +8 WRITE !!
- +9 SET CDT=$$FMTE^XLFDT(+DT,5)
- +10 ;
- STRTDT ;
- +1 ;
- +2 WRITE !!,"Selection will be made based off of the create date of the Request",!!
- +3 ;
- SET DIR(0)="DAO^3170101:"_+DT_":EX"
- SET DIR("A")="SDEC APPOINTMENT REQUEST CREATE DATE to start selection: "
- SET DIR("B")=$$FMTE^XLFDT($$FMADD^XLFDT(+DT,-30),5)
- +4 ;
- SET DIR("?",1)="Enter the CREATE date to start the SDEC APPT REQUEST search."
- SET DIR("?")="The date must be between 1/1/2017 and "_CDT
- +5 ;
- DO ^DIR
- if +Y<1
- QUIT
- +6 ;
- IF +Y>0
- SET SDSDT=Y
- +7 ;
- ENDDT ;
- +1 ;
- +2 NEW %
- +3 KILL DIROUT,DIRUT,DTOUT,DUOUT
- +4 ;
- SET (X,Y)=""
- +5 ;
- SET DIR(0)="DAO^"_SDSDT_":"_+DT_":EX"
- SET DIR("A")="SDEC APPOINTMENT REQUEST CREATE DATE to end selection: "
- SET DIR("B")=$$FMTE^XLFDT(+DT,5)
- +6 ;
- SET DIR("?",1)="Enter the CREATE date to stop the SDEC APPT REQUEST search."
- SET DIR("?")="The date must be between "_$$FMTE^XLFDT(SDSDT,5)_" and "_CDT
- +7 ;
- DO ^DIR
- +8 ;
- if +$GET(DTOUT)
- GOTO STRTDT
- +9 ;
- if +Y<1
- QUIT
- +10 ;
- IF +Y>0
- SET SDEDT=Y
- +11 KILL DIR
- +12 SET DIR(0)="Y"
- +13 SET DIR("A")="Are you sure you would like to run the SDEC PENDING RTC clean-up"
- +14 SET DIR("?")="Enter 'Y'es or 'N'o."
- +15 SET DIR("B")="YES"
- +16 DO ^DIR
- +17 KILL DIR
- +18 if $GET(DIRUT)!(Y=0)
- GOTO EXIT
- +19 DO LOOP(SDSDT,SDEDT)
- +20 if POP
- DO EXIT
- QUIT
- +21 ;
- DO FIN(CNT)
- +22 QUIT
- +23 ;
- FULL ;
- +1 ;
- +2 ; Perform a full clean-up starting from 1/1/2017
- +3 ;
- +4 NEW CNT,POP,SDSDT,SDEDT,%
- +5 SET POP=0
- +6 ;
- DO START
- +7 ;
- SET SDSDT=3170101
- SET SDEDT=999999999
- SET CNT=0
- +8 KILL DIR
- +9 WRITE !
- +10 SET DIR(0)="Y"
- +11 SET DIR("A")="Are you sure you would like to run the FULL SDEC PENDING RTC clean-up"
- +12 SET DIR("?")="Enter 'Y'es or 'N'o."
- +13 SET DIR("B")="YES"
- +14 DO ^DIR
- +15 KILL DIR
- +16 if $GET(DIRUT)!(Y=0)
- GOTO EXIT
- +17 DO LOOP(SDSDT,SDEDT)
- +18 if POP
- DO EXIT
- QUIT
- +19 ;
- DO FIN(CNT)
- +20 QUIT
- +21 ;
- LOOP(SDSDT,SDEDT) ;
- +1 ;
- +2 ; Loop through closed SDEC APPT REQUESTS to complete corresponding RTC Orders
- +3 ;
- +4 ;
- NEW %H,CMT,CMTE,DTPURG,END,INPUT,ORDIS,ORIEN,ORPENDING,ORSTATUS,SDCDT,SDDISP,SDDISPBY,SDDISPDT,SDEC0,SDECDIS,SDIEN,SDPAR,SDPATIENT,SDRQTYPE,STOP,DFN,VADM
- +5 NEW SKIP,SKIPFLG
- +6 SET POP=0
- +7 ;
- +8 DO ^%ZIS
- if POP
- QUIT
- +9 ;
- WRITE !!,"Starting search and clean-up...."
- +10 ;
- +11 USE IO
- +12 WRITE !!,"Orders updated via the Clean-up Tool:",!
- +13 ;
- +14 ;
- SET SDCDT=$$FMADD^XLFDT(SDSDT,-1)
- SET DTPURG=$$FMADD^XLFDT(+DT,7)
- SET END=0
- +15 ; ICR #2638
- SET ORPENDING=+$ORDER(^ORD(100.01,"B","PENDING",0))
- +16 SET CMT="Orders changed to Completed based on SDEC APPT REQUEST being in status of Closed"
- +17 SET CMTE="Errors during Orders being changed to Completed based on SDEC APPT REQUEST being in status of Closed"
- +18 ;
- +19 ;
- SET ^XTMP("OR PENDING RTC CLEAN-UP-"_$$FMTE^XLFDT(DT),0)=DTPURG_U_+DT_U_CMT
- +20 ;
- +21 ; Loop thru closed SDEC APPT REQUESTS
- +22 ;
- +23 ;
- FOR
- SET SDCDT=$ORDER(^SDEC(409.85,"E","C",SDCDT))
- if SDCDT=""
- QUIT
- Begin DoDot:1
- +24 ;
- IF SDCDT>SDEDT
- SET END=1
- QUIT
- +25 ;
- SET SDIEN=""
- FOR
- SET SDIEN=$ORDER(^SDEC(409.85,"E","C",SDCDT,SDIEN))
- if SDIEN=""
- QUIT
- Begin DoDot:2
- +26 ;
- KILL INPUT
- +27 SET SKIPFLG=0
- +28 ; Skip if not RTC order.
- SET SDEC0=$GET(^SDEC(409.85,SDIEN,0))
- SET SDRQTYPE=$PIECE(SDEC0,U,5)
- if SDRQTYPE'="RTC"
- QUIT
- +29 ;
- +30 ; Skip if not sourced from CPRS (bad data)
- SET ORIEN=+$PIECE($GET(^SDEC(409.85,SDIEN,7)),U,1)
- if ORIEN=0
- QUIT
- +31 ; ICR #7156
- SET ORSTATUS=$$GET1^DIQ(100,ORIEN,5,"I")
- +32 ; Skip if order is not pending
- if ORSTATUS'=ORPENDING
- QUIT
- +33 ;
- +34 SET SDECDIS=$GET(^SDEC(409.85,SDIEN,"DIS"))
- +35 SET SDPATIENT=+$PIECE(SDEC0,U,1)
- +36 IF SDPATIENT=0
- Begin DoDot:3
- +37 SET SKIPFLG=SKIPFLG+1
- +38 ; Skip if patient pointer missing (bad data)
- SET SKIP(SDIEN,SKIPFLG)="Patient pointer missing (bad data)"
- End DoDot:3
- +39 ;
- +40 SET SDDISPBY=+$PIECE(SDECDIS,U,2)
- +41 IF SDDISPBY=0
- Begin DoDot:3
- +42 SET SKIPFLG=SKIPFLG+1
- +43 SET SKIP(SDIEN,SKIPFLG)="Disposition By field is missing"
- End DoDot:3
- +44 SET SDDISPDT=$PIECE(SDECDIS,U,1)
- +45 IF +SDDISPDT=0
- Begin DoDot:3
- +46 ; Skip if disposition date is missing
- SET SKIPFLG=SKIPFLG+1
- +47 SET SKIP(SDIEN,SKIPFLG)="Disposition Date field is missing"
- End DoDot:3
- +48 SET SDDISP=$PIECE(SDECDIS,U,3)
- +49 IF SDDISP=""
- Begin DoDot:3
- +50 ; Skip if disposition is missing
- SET SKIPFLG=SKIPFLG+1
- +51 SET SKIP(SDIEN,SKIPFLG)="Disposition field is missing"
- End DoDot:3
- +52 ;
- +53 IF +$PIECE($GET(^SDEC(409.85,SDIEN,3)),U,5)
- Begin DoDot:3
- +54 SET SKIPFLG=SKIPFLG+1
- +55 ; Skip if child request
- SET SKIP(SDIEN,SKIPFLG)="Skipped child request."
- End DoDot:3
- +56 ;
- +57 ;skip if any errors
- if SKIPFLG
- QUIT
- +58 ;S ORDIS=$S(SDDISP="SA":0,SDDISP="MC":0,1:1) ;
- +59 SET ORDIS=$SELECT(SDDISP=3:0,SDDISP=9:0,SDDISP="REMOVED/SCHEDULED-ASSIGNED":0,SDDISP="MRTC PARENT CLOSED":0,1:1)
- +60 ;
- +61 ; ICR #10061
- KILL VADM
- SET DFN=SDPATIENT
- DO DEM^VADPT
- +62 ;
- +63 ; For child request, skip if parent closed. I don't think this code will ever apply since child requests are ignored.
- +64 ;
- +65 SET STOP=0
- +66 SET SDPAR=+$PIECE(^SDEC(409.85,SDIEN,3),U,5)
- IF SDPAR
- Begin DoDot:3
- +67 IF $PIECE($GET(^SDEC(409.85,SDPAR,0)),U,17)="C"
- SET STOP=1
- QUIT
- +68 ;S INPUT("PARTIAL")=1
- End DoDot:3
- +69 ;Don't process partials if Parent closed
- IF STOP=1
- QUIT
- +70 ;
- +71 ; Send HL7 message to update CPRS order file entry.
- +72 ;
- +73 ;
- DO SDHL7BLD(SDIEN,ORIEN,SDDISPBY,DFN,VADM(1),ORDIS)
- +74 ;
- +75 ; Store record of entry closed.
- +76 ;
- +77 ;
- SET CNT=CNT+1
- SET ^XTMP("OR PENDING RTC CLEAN-UP-"_$$FMTE^XLFDT(DT),$JOB,ORIEN,0)=SDIEN_U_SDPATIENT_U_SDDISPDT_U_SDDISPBY_U_SDDISP_U_ORSTATUS
- +78 DO PRNTCLEAN
- End DoDot:2
- End DoDot:1
- if END
- QUIT
- +79 ;
- +80 IF CNT=0
- WRITE !," No updates were completed."
- +81 ;print skipped records
- if ($DATA(SKIP))
- DO PRNTSKIP
- +82 QUIT
- +83 ;
- START ;Show introductory text
- +1 ;
- +2 ;
- WRITE !!,"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."
- +3 QUIT
- +4 ;
- FIN(CNT) ;Show final results
- +1 ;
- +2 DO ^%ZISC
- +3 ;
- WRITE !!!!,"Search and clean-up is complete!!!!",!,CNT," Orders were updated!"
- +4 ;
- +5 ;
- IF CNT>0
- WRITE !!,"Orders that are updated will be saved for 7 days in the",!,"^XTMP(""OR PENDING RTC CLEAN-UP"_"-"_$$FMTE^XLFDT(DT)_""","_$JOB_" global."
- +6 QUIT
- +7 ;
- PRNTSKIP ;Print any IENs that were skipped.
- +1 NEW SDIEN,XINDX
- +2 WRITE !!,"*********************************************************************"
- +3 WRITE !!,"The following SDEC APPOINTMENT REQUEST IENs were skipped:",!
- +4 SET SDIEN=""
- +5 FOR
- SET SDIEN=$ORDER(SKIP(SDIEN))
- if SDIEN=""
- QUIT
- Begin DoDot:1
- +6 SET XINDX=""
- +7 WRITE !!,"Request IEN "_SDIEN_":"
- +8 FOR
- SET XINDX=$ORDER(SKIP(SDIEN,XINDX))
- if XINDX=""
- QUIT
- Begin DoDot:2
- +9 WRITE !," "_$GET(SKIP(SDIEN,XINDX))
- End DoDot:2
- End DoDot:1
- +10 QUIT
- +11 ;
- PRNTCLEAN ;Print information from IENS that were cleaned up
- +1 WRITE !!,"Request IEN = "_SDIEN_" Patient = "_VADM(1)_" Clinic = "_$$GET1^DIQ(409.85,SDIEN,8,"E")
- +2 WRITE !,"Order IEN = "_ORIEN
- +3 WRITE !," Original Order Status = "_$$GET1^DIQ(100.01,ORSTATUS_",",.01,"E")
- +4 WRITE !," Order Status After Cleanup = "_$$GET1^DIQ(100,ORIEN,5,"E")
- +5 WRITE !,"Request Disposition = "_$$GET1^DIQ(409.85,SDIEN,21,"E")
- +6 WRITE !," Disposition Date = "_$$FMTE^XLFDT(SDDISPDT,"1F")
- +7 WRITE !," Dispositioned By = "_$$GET1^DIQ(200,SDDISPBY,.01,"E")
- +8 WRITE !
- +9 QUIT
- +10 ;
- EXIT ;Exit without runnign clean up
- +1 WRITE !!,"Nothing done."
- +2 QUIT
- +3 ;
- SDHL7BLD(SDIEN,ORIEN,SDDISPBY,SDPATIENT,PATNAME,ORDIS) ;
- +1 ;
- +2 ; Build HL7 message to send to CPRS to update order file.
- +3 ;
- +4 ;
- NEW INPUTS,CLINIC
- +5 ;
- +6 ; Appointment request
- SET INPUTS("REQ FILE IEN")=SDIEN
- +7 ;
- +8 ;clinic
- SET INPUTS("CLINIC")=$$GET1^DIQ(409.85,SDIEN,8,"I")_U_$$GET1^DIQ(409.85,SDIEN,8,"E")
- +9 ;
- +10 ;
- SET INPUTS("COMMENT")="RTC dispositioned by clean up process."
- +11 ;
- +12 ; Dispositioned by
- SET INPUTS("DISPOSITION BY")=SDDISPBY_U_$$GET1^DIQ(200,SDDISPBY,.01,"E")
- +13 ;
- +14 ; Disposition
- SET INPUTS("DISCONTINUE")=ORDIS
- +15 ;
- +16 ;
- SET INPUTS("NUMBER APPT")=1
- +17 ;
- +18 ; Order file (#100) pointer
- SET INPUTS("ORDER IEN")=ORIEN
- +19 ;
- +20 ; Patient pointer and name
- SET INPUTS("PATIENT")=SDPATIENT_U_PATNAME
- +21 ;
- +22 ; CID
- SET INPUTS("RTC DATE")=$PIECE(^SDEC(409.85,SDIEN,0),U,16)
- +23 ;
- +24 ;
- DO EN^SDHL7BLD(.INPUTS)
- +25 ;
- QUIT