SDESORDCLEAN ;ALB/LAB - Clean-up of Pending and partialdd RTC orders ;Dec 06,2022@08:00
;;5.3;Scheduling;**831**;Aug 13, 1993;Build 4
;;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.
;
Q
;
; 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
; Reference to ^OR(100 in ICR 5771
Q
;
CLEANDATA ;
N ORDERIENS,ORDERIEN,ERROR,POP,REQIEN,DISPOSITION,PATIENT,STATUS
S POP=0
S ORDERIEN=""
D START
D ORDPROMPT(.ORDERIENS,.POP) Q:POP
D DEVICEPROMPT
F S ORDERIEN=$O(ORDERIENS(ORDERIEN)) Q:ORDERIEN="" D
. N STATUS,REQIEN,ORDSTAT,DISPSOTION,PATIENT
. S POP=0
. D CHECKORDERSTAT(ORDERIEN,.STATUS,.POP)
. D:'POP GETREQUESTIEN(ORDERIEN,.REQIEN,.POP)
. D:'POP GETDISPOSITION(REQIEN,.ORDSTAT,.POP,.DISPOSITION)
. D:'POP MATCHORDTOREQ(ORDERIEN,REQIEN,.POP,.PATIENT)
. D:'POP CLEANUPSTEPS(ORDERIEN,STATUS,DISPOSITION,PATIENT,REQIEN,POP)
D FIN
Q
;
DEVICEPROMPT ;prompt for device
D ^%ZIS Q:POP
U IO
Q
;
FIN ;Show final results
;
D ^%ZISC
Q
;
GETDISPOSITION(REQIEN,ORDSTAT,POP,DISPOSITION) ;
I $$GET1^DIQ(409.85,REQIEN_",",23,"E")="OPEN" D
. S POP=1
. W !,"Request for Order is still open, no status update"
Q:POP
S DISPOSITION=$$GET1^DIQ(409.85,REQIEN_",",21)
Q
ORDPROMPT(ORDERIENS,POP) ;enter order number
NEW DIC,Y,X,LEAVE
S LEAVE=0
F Q:(LEAVE)!(POP) D
. S DIC("A")="Enter the Order Number: "
. S DIC=100,DIC(0)="AEQN" D ^DIC
. S:(X="") LEAVE=1
. S:(X="^") POP=1
. Q:LEAVE!POP
. S X=$TR(X,"`")
. S ORDERIENS(X)=""
Q
CHECKORDERSTAT(ORDERIEN,STATUS,POP) ;is order status in range
S POP=0
S STATUS=$$GET1^DIQ(100,ORDERIEN_",",5,"E")
S POP=$S(STATUS="PENDING":0,STATUS="PARTIAL RESULTS":0,1:1)
I POP W !,"Current status for ORDER ",ORDERIEN," is ",STATUS,". No status change."
Q
GETREQUESTIEN(ORDERIEN,REQIEN,POP) ;get request IEN
N PARENTREQ
S REQIEN=$$GET1^DIQ(100,ORDERIEN_",",33,"I")
S PARENTREQ=$$GET1^DIQ(409.85,REQIEN_",",43.8,"I")
S:PARENTREQ'="" REQIEN=PARENTREQ
I (REQIEN="")!($$GET1^DIQ(409.85,REQIEN_",",.01)="") D
. W !,"Could not find request on ORDER. Please submit a YourIT ticket for the Scheduling Team."
. S POP=1
Q
MATCHORDTOREQ(ORDERIEN,REQIEN,POP,OBJOFORDER) ; Match order with request quit if they do not match
NEW REQORDER,REQORIGUSR,REQPATIENT,WHOORDERED
S OBJOFORDER=$P($$GET1^DIQ(100,ORDERIEN_",",.02,"I"),";",1)
Q:$$GET1^DIQ(409.85,REQIEN_",",46,"I")=ORDERIEN
S OBJOFORDER=$P($$GET1^DIQ(100,ORDERIEN_",",.02,"I"),";",1)
S REQPATIENT=$$GET1^DIQ(409.85,REQIEN_",",.01,"I")
S REQORIGUSR=$$GET1^DIQ(409.85,REQIEN_",",9,"I")
S WHOORDERED=$$GET1^DIQ(100,ORDERIEN_",",3,"I")
;
I (OBJOFORDER'=REQPATIENT)!(REQORIGUSR'=WHOORDERED) D
. S POP=1
. W !,"Order did not match request. Please submit a YourIT ticket for the Scheduling Team."
Q:POP
D UPDATEREQ(REQIEN,ORDERIEN)
Q
UPDATEREQ(REQIEN,ORDERIEN) ;update order field in request with order if missing
N FDA,FDAERR
S FDA(409.85,REQIEN,46)=ORDERIEN
D FILE^DIE(,"FDA","FDAERR") K FDA
Q
;
CLEANUPSTEPS(ORIEN,ORSTATUS,DISPOSITION,SDPATIENT,SDIEN,POP) ;
N DFN,SDDISPBY,SDDISPDT
S SDDISPBY=$$GET1^DIQ(409.85,REQIEN_",",20,"I")
I +SDDISPBY=0 D
. W !,"Disposition By field is missing from request. Status has not been udpated."
. S POP=1
S SDDISPDT=$$GET1^DIQ(409.85,REQIEN_",",19,"I")
I +SDDISPDT=0 D
. W !,"Disposition Date field is missing from request. Status has not been updated."
. S POP=1
Q:POP
S ORDIS=$S(DISPOSITION="REMOVED/SCHEDULED-ASSIGNED":0,DISPOSITION="MRTC PARENT CLOSED":0,1:1)
K VADM S DFN=SDPATIENT D DEM^VADPT ; ICR #10061
; Send HL7 message to update CPRS order file entry.
;
D SDHL7BLD(SDIEN,ORIEN,SDDISPBY,DFN,VADM(1),ORDIS) ;
;
W !,"ORDER "_ORIEN_" was successfully updated."
Q
;
START ;Show introductory text
;
W !!,"This OPTION will verify if the entered ORDER is stuck in the incorrect status. "
W " The status will be updated based on the Request status."
Q
;
SDHL7BLD(SDIEN,ORIEN,SDDISPBY,SDPATIENT,PATNAME,ORDIS) ;
N NUMBAPPTS
;
; 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 NUMBAPPTS=$$GET1^DIQ(409.85,SDIEN,43,"I")
S INPUTS("NUMBER APPT")=$S(NUMBAPPTS>1:NUMBAPPTS,1: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[HSDESORDCLEAN 5257 printed Apr 09, 2024@21:40:26 Page 2
SDESORDCLEAN ;ALB/LAB - Clean-up of Pending and partialdd RTC orders ;Dec 06,2022@08:00
+1 ;;5.3;Scheduling;**831**;Aug 13, 1993;Build 4
+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 QUIT
+8 ;
+9 ; Documented API's and Integration Agreements
+10 ; -------------------------------------------
+11 ; Reference to ^ORD(100.01 in ICR #2638
+12 ; Reference to ^OR(100 in ICR #7156
+13 ; Reference to ^VA(200 in ICR #10060
+14 ; Reference to DEM^VADPT in ICR #10061
+15 ; Reference to ^OR(100 in ICR 5771
+16 QUIT
+17 ;
CLEANDATA ;
+1 NEW ORDERIENS,ORDERIEN,ERROR,POP,REQIEN,DISPOSITION,PATIENT,STATUS
+2 SET POP=0
+3 SET ORDERIEN=""
+4 DO START
+5 DO ORDPROMPT(.ORDERIENS,.POP)
if POP
QUIT
+6 DO DEVICEPROMPT
+7 FOR
SET ORDERIEN=$ORDER(ORDERIENS(ORDERIEN))
if ORDERIEN=""
QUIT
Begin DoDot:1
+8 NEW STATUS,REQIEN,ORDSTAT,DISPSOTION,PATIENT
+9 SET POP=0
+10 DO CHECKORDERSTAT(ORDERIEN,.STATUS,.POP)
+11 if 'POP
DO GETREQUESTIEN(ORDERIEN,.REQIEN,.POP)
+12 if 'POP
DO GETDISPOSITION(REQIEN,.ORDSTAT,.POP,.DISPOSITION)
+13 if 'POP
DO MATCHORDTOREQ(ORDERIEN,REQIEN,.POP,.PATIENT)
+14 if 'POP
DO CLEANUPSTEPS(ORDERIEN,STATUS,DISPOSITION,PATIENT,REQIEN,POP)
End DoDot:1
+15 DO FIN
+16 QUIT
+17 ;
DEVICEPROMPT ;prompt for device
+1 DO ^%ZIS
if POP
QUIT
+2 USE IO
+3 QUIT
+4 ;
FIN ;Show final results
+1 ;
+2 DO ^%ZISC
+3 QUIT
+4 ;
GETDISPOSITION(REQIEN,ORDSTAT,POP,DISPOSITION) ;
+1 IF $$GET1^DIQ(409.85,REQIEN_",",23,"E")="OPEN"
Begin DoDot:1
+2 SET POP=1
+3 WRITE !,"Request for Order is still open, no status update"
End DoDot:1
+4 if POP
QUIT
+5 SET DISPOSITION=$$GET1^DIQ(409.85,REQIEN_",",21)
+6 QUIT
ORDPROMPT(ORDERIENS,POP) ;enter order number
+1 NEW DIC,Y,X,LEAVE
+2 SET LEAVE=0
+3 FOR
if (LEAVE)!(POP)
QUIT
Begin DoDot:1
+4 SET DIC("A")="Enter the Order Number: "
+5 SET DIC=100
SET DIC(0)="AEQN"
DO ^DIC
+6 if (X="")
SET LEAVE=1
+7 if (X="^")
SET POP=1
+8 if LEAVE!POP
QUIT
+9 SET X=$TRANSLATE(X,"`")
+10 SET ORDERIENS(X)=""
End DoDot:1
+11 QUIT
CHECKORDERSTAT(ORDERIEN,STATUS,POP) ;is order status in range
+1 SET POP=0
+2 SET STATUS=$$GET1^DIQ(100,ORDERIEN_",",5,"E")
+3 SET POP=$SELECT(STATUS="PENDING":0,STATUS="PARTIAL RESULTS":0,1:1)
+4 IF POP
WRITE !,"Current status for ORDER ",ORDERIEN," is ",STATUS,". No status change."
+5 QUIT
GETREQUESTIEN(ORDERIEN,REQIEN,POP) ;get request IEN
+1 NEW PARENTREQ
+2 SET REQIEN=$$GET1^DIQ(100,ORDERIEN_",",33,"I")
+3 SET PARENTREQ=$$GET1^DIQ(409.85,REQIEN_",",43.8,"I")
+4 if PARENTREQ'=""
SET REQIEN=PARENTREQ
+5 IF (REQIEN="")!($$GET1^DIQ(409.85,REQIEN_",",.01)="")
Begin DoDot:1
+6 WRITE !,"Could not find request on ORDER. Please submit a YourIT ticket for the Scheduling Team."
+7 SET POP=1
End DoDot:1
+8 QUIT
MATCHORDTOREQ(ORDERIEN,REQIEN,POP,OBJOFORDER) ; Match order with request quit if they do not match
+1 NEW REQORDER,REQORIGUSR,REQPATIENT,WHOORDERED
+2 SET OBJOFORDER=$PIECE($$GET1^DIQ(100,ORDERIEN_",",.02,"I"),";",1)
+3 if $$GET1^DIQ(409.85,REQIEN_",",46,"I")=ORDERIEN
QUIT
+4 SET OBJOFORDER=$PIECE($$GET1^DIQ(100,ORDERIEN_",",.02,"I"),";",1)
+5 SET REQPATIENT=$$GET1^DIQ(409.85,REQIEN_",",.01,"I")
+6 SET REQORIGUSR=$$GET1^DIQ(409.85,REQIEN_",",9,"I")
+7 SET WHOORDERED=$$GET1^DIQ(100,ORDERIEN_",",3,"I")
+8 ;
+9 IF (OBJOFORDER'=REQPATIENT)!(REQORIGUSR'=WHOORDERED)
Begin DoDot:1
+10 SET POP=1
+11 WRITE !,"Order did not match request. Please submit a YourIT ticket for the Scheduling Team."
End DoDot:1
+12 if POP
QUIT
+13 DO UPDATEREQ(REQIEN,ORDERIEN)
+14 QUIT
UPDATEREQ(REQIEN,ORDERIEN) ;update order field in request with order if missing
+1 NEW FDA,FDAERR
+2 SET FDA(409.85,REQIEN,46)=ORDERIEN
+3 DO FILE^DIE(,"FDA","FDAERR")
KILL FDA
+4 QUIT
+5 ;
CLEANUPSTEPS(ORIEN,ORSTATUS,DISPOSITION,SDPATIENT,SDIEN,POP) ;
+1 NEW DFN,SDDISPBY,SDDISPDT
+2 SET SDDISPBY=$$GET1^DIQ(409.85,REQIEN_",",20,"I")
+3 IF +SDDISPBY=0
Begin DoDot:1
+4 WRITE !,"Disposition By field is missing from request. Status has not been udpated."
+5 SET POP=1
End DoDot:1
+6 SET SDDISPDT=$$GET1^DIQ(409.85,REQIEN_",",19,"I")
+7 IF +SDDISPDT=0
Begin DoDot:1
+8 WRITE !,"Disposition Date field is missing from request. Status has not been updated."
+9 SET POP=1
End DoDot:1
+10 if POP
QUIT
+11 SET ORDIS=$SELECT(DISPOSITION="REMOVED/SCHEDULED-ASSIGNED":0,DISPOSITION="MRTC PARENT CLOSED":0,1:1)
+12 ; ICR #10061
KILL VADM
SET DFN=SDPATIENT
DO DEM^VADPT
+13 ; Send HL7 message to update CPRS order file entry.
+14 ;
+15 ;
DO SDHL7BLD(SDIEN,ORIEN,SDDISPBY,DFN,VADM(1),ORDIS)
+16 ;
+17 WRITE !,"ORDER "_ORIEN_" was successfully updated."
+18 QUIT
+19 ;
START ;Show introductory text
+1 ;
+2 WRITE !!,"This OPTION will verify if the entered ORDER is stuck in the incorrect status. "
+3 WRITE " The status will be updated based on the Request status."
+4 QUIT
+5 ;
SDHL7BLD(SDIEN,ORIEN,SDDISPBY,SDPATIENT,PATNAME,ORDIS) ;
+1 NEW NUMBAPPTS
+2 ;
+3 ; Build HL7 message to send to CPRS to update order file.
+4 ;
+5 ;
NEW INPUTS,CLINIC
+6 ;
+7 ; Appointment request
SET INPUTS("REQ FILE IEN")=SDIEN
+8 ;
+9 ;clinic
SET INPUTS("CLINIC")=$$GET1^DIQ(409.85,SDIEN,8,"I")_U_$$GET1^DIQ(409.85,SDIEN,8,"E")
+10 ;
+11 ;
SET INPUTS("COMMENT")="RTC dispositioned by clean up process."
+12 ;
+13 ; Dispositioned by
SET INPUTS("DISPOSITION BY")=SDDISPBY_U_$$GET1^DIQ(200,SDDISPBY,.01,"E")
+14 ;
+15 ; Disposition
SET INPUTS("DISCONTINUE")=ORDIS
+16 ;
+17 SET NUMBAPPTS=$$GET1^DIQ(409.85,SDIEN,43,"I")
+18 SET INPUTS("NUMBER APPT")=$SELECT(NUMBAPPTS>1:NUMBAPPTS,1:1)
+19 ;
+20 ; Order file (#100) pointer
SET INPUTS("ORDER IEN")=ORIEN
+21 ;
+22 ; Patient pointer and name
SET INPUTS("PATIENT")=SDPATIENT_U_PATNAME
+23 ;
+24 ; CID
SET INPUTS("RTC DATE")=$PIECE(^SDEC(409.85,SDIEN,0),U,16)
+25 ;
+26 ;
DO EN^SDHL7BLD(.INPUTS)
+27 ;
QUIT
