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

SDESORDCLEAN.m

Go to the documentation of this file. 
  1. 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
  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.  Q
  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.  ; Reference to ^OR(100 in ICR 5771
  1.  Q
  1.  ;
  1. CLEANDATA ;
  1.  N ORDERIENS,ORDERIEN,ERROR,POP,REQIEN,DISPOSITION,PATIENT,STATUS
  1.  S POP=0
  1.  S ORDERIEN=""
  1.  D START
  1.  D ORDPROMPT(.ORDERIENS,.POP) Q:POP
  1.  D DEVICEPROMPT
  1.  F  S ORDERIEN=$O(ORDERIENS(ORDERIEN)) Q:ORDERIEN=""  D
  1.  . N STATUS,REQIEN,ORDSTAT,DISPSOTION,PATIENT
  1.  . S POP=0
  1.  . D CHECKORDERSTAT(ORDERIEN,.STATUS,.POP)
  1.  . D:'POP GETREQUESTIEN(ORDERIEN,.REQIEN,.POP)
  1.  . D:'POP GETDISPOSITION(REQIEN,.ORDSTAT,.POP,.DISPOSITION)
  1.  . D:'POP MATCHORDTOREQ(ORDERIEN,REQIEN,.POP,.PATIENT)
  1.  . D:'POP CLEANUPSTEPS(ORDERIEN,STATUS,DISPOSITION,PATIENT,REQIEN,POP)
  1.  D FIN
  1.  Q
  1.  ;
  1. DEVICEPROMPT ;prompt for device
  1.  D ^%ZIS Q:POP
  1.  U IO
  1.  Q
  1.  ;
  1. FIN ;Show final results
  1.  ;
  1.  D ^%ZISC
  1.  Q
  1.  ;
  1. GETDISPOSITION(REQIEN,ORDSTAT,POP,DISPOSITION) ;
  1.  I $$GET1^DIQ(409.85,REQIEN_",",23,"E")="OPEN" D
  1.  . S POP=1
  1.  . W !,"Request for Order is still open, no status update"
  1.  Q:POP
  1.  S DISPOSITION=$$GET1^DIQ(409.85,REQIEN_",",21)
  1.  Q
  1. ORDPROMPT(ORDERIENS,POP) ;enter order number
  1.  NEW DIC,Y,X,LEAVE
  1.  S LEAVE=0
  1.  F  Q:(LEAVE)!(POP)  D
  1.  . S DIC("A")="Enter the Order Number: "
  1.  . S DIC=100,DIC(0)="AEQN" D ^DIC
  1.  . S:(X="") LEAVE=1
  1.  . S:(X="^") POP=1
  1.  . Q:LEAVE!POP
  1.  . S X=$TR(X,"`")
  1.  . S ORDERIENS(X)=""
  1.  Q
  1. CHECKORDERSTAT(ORDERIEN,STATUS,POP) ;is order status in range
  1.  S POP=0
  1.  S STATUS=$$GET1^DIQ(100,ORDERIEN_",",5,"E")
  1.  S POP=$S(STATUS="PENDING":0,STATUS="PARTIAL RESULTS":0,1:1)
  1.  I POP W !,"Current status for ORDER ",ORDERIEN," is ",STATUS,".  No status change."
  1.  Q
  1. GETREQUESTIEN(ORDERIEN,REQIEN,POP) ;get request IEN
  1.  N PARENTREQ
  1.  S REQIEN=$$GET1^DIQ(100,ORDERIEN_",",33,"I")
  1.  S PARENTREQ=$$GET1^DIQ(409.85,REQIEN_",",43.8,"I")
  1.  S:PARENTREQ'="" REQIEN=PARENTREQ
  1.  I (REQIEN="")!($$GET1^DIQ(409.85,REQIEN_",",.01)="") D
  1.  . W !,"Could not find request on ORDER.  Please submit a YourIT ticket for the Scheduling Team."
  1.  . S POP=1
  1.  Q
  1. MATCHORDTOREQ(ORDERIEN,REQIEN,POP,OBJOFORDER) ; Match order with request quit if they do not match
  1.  NEW REQORDER,REQORIGUSR,REQPATIENT,WHOORDERED
  1.  S OBJOFORDER=$P($$GET1^DIQ(100,ORDERIEN_",",.02,"I"),";",1)
  1.  Q:$$GET1^DIQ(409.85,REQIEN_",",46,"I")=ORDERIEN
  1.  S OBJOFORDER=$P($$GET1^DIQ(100,ORDERIEN_",",.02,"I"),";",1)
  1.  S REQPATIENT=$$GET1^DIQ(409.85,REQIEN_",",.01,"I")
  1.  S REQORIGUSR=$$GET1^DIQ(409.85,REQIEN_",",9,"I")
  1.  S WHOORDERED=$$GET1^DIQ(100,ORDERIEN_",",3,"I")
  1.  ;
  1.  I (OBJOFORDER'=REQPATIENT)!(REQORIGUSR'=WHOORDERED) D
  1.  . S POP=1
  1.  . W !,"Order did not match request. Please submit a YourIT ticket for the Scheduling Team."
  1.  Q:POP
  1.  D UPDATEREQ(REQIEN,ORDERIEN)
  1.  Q
  1. UPDATEREQ(REQIEN,ORDERIEN) ;update order field in request with order if missing
  1.  N FDA,FDAERR
  1.  S FDA(409.85,REQIEN,46)=ORDERIEN
  1.  D FILE^DIE(,"FDA","FDAERR") K FDA
  1.  Q
  1.  ;
  1. CLEANUPSTEPS(ORIEN,ORSTATUS,DISPOSITION,SDPATIENT,SDIEN,POP) ;
  1.  N DFN,SDDISPBY,SDDISPDT
  1.  S SDDISPBY=$$GET1^DIQ(409.85,REQIEN_",",20,"I")
  1.  I +SDDISPBY=0 D
  1.  . W !,"Disposition By field is missing from request.  Status has not been udpated."
  1.  . S POP=1
  1.  S SDDISPDT=$$GET1^DIQ(409.85,REQIEN_",",19,"I")
  1.  I +SDDISPDT=0 D
  1.  . W !,"Disposition Date field is missing from request.  Status has not been updated."
  1.  . S POP=1
  1.  Q:POP
  1.  S ORDIS=$S(DISPOSITION="REMOVED/SCHEDULED-ASSIGNED":0,DISPOSITION="MRTC PARENT CLOSED":0,1:1)
  1.  K VADM S DFN=SDPATIENT D DEM^VADPT ; ICR #10061
  1.  ;  Send HL7 message to update CPRS order file entry.
  1.  ;
  1.  D SDHL7BLD(SDIEN,ORIEN,SDDISPBY,DFN,VADM(1),ORDIS) ;
  1.  ;
  1.  W !,"ORDER "_ORIEN_" was successfully updated."
  1.  Q
  1.  ;
  1. START ;Show introductory text
  1.  ;
  1.  W !!,"This OPTION will verify if the entered ORDER is stuck in the incorrect status. "
  1.  W " The status will be updated based on the Request status."
  1.  Q
  1.  ;
  1. SDHL7BLD(SDIEN,ORIEN,SDDISPBY,SDPATIENT,PATNAME,ORDIS) ;
  1.  N NUMBAPPTS
  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 NUMBAPPTS=$$GET1^DIQ(409.85,SDIEN,43,"I")
  1.  S INPUTS("NUMBER APPT")=$S(NUMBAPPTS>1:NUMBAPPTS,1: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  ;