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 Dec 13, 2024@02:52:40 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
