PSOUTOR ;HPS/DSK - MEDICATION ORDER STATUS CHECK; Oct 22, 2024@10:20
;;7.0;OUTPATIENT PHARMACY;**546,775**;DEC 1997;Build 1
;
;Reference to: Supported by:
;------------- -------------
;^OR(100 IA #3582
;DISPLAY GROUP (#100.98) file IA #873
;ORDER STATUS (#100.01) file IA #875
;ORDERABLE ITEMS (#101.43) file IA #5430
;DRUG (#50) file IA #221
;PHARMACY PATIENT (#55) file IA #6987
;^XLFDT IA #10103
;DD^%DT IA #10003
;NOW^%DTC IA #10000
;^%ZTLOAD IA #10063
;STATUS^ORCSAVE2 IA #5903
;$$SETUP1^XQALERT IA #10081
;NOTE: SACC guidelines allow lowercase subscripts in ^TMP and ^XTMP.
;
;PSO*7.0*775: Deleted requirement that start date precede login date
; of first IEN in the ORDERS (#100) file. The lowest IEN
; may not necessarily correspond to the install of CPRS.
;
;Search Logic
;============
;
;This routine searches for discontinued medication orders with discontinued
;or expired statuses which are still active in the ORDERS (#100) file.
;
;^XTMP Subscript Logic
;=====================
;
;Subscripts in ^XTMP are set with verbiage that will aid anyone who reviews the search
;results as to the issues which were found. Data is kept in ^XTMP for 60 days.
;
;MailMan Message / Alert Logic
;=============================
;
;MailMan messages and an alert are generated to the user who invoked the search option.
;
Q
;
EN ;Status Mismatch Search
N DIR,DTOUT,DUOUT,Y,PSOQUIT,PSOSDT,PSOEDT,PSOTYP,PSOCORR,PSOVER,PSODUZ,PSOAR
S PSOQUIT=0,PSODUZ=""
;
;PSOAR used for user display and MailMan messaging
S PSOAR("I")="Inpatient",PSOAR("O")="Outpatient",PSOAR("N")="Non-VA"
S PSOAR("IO")="Inpatient and Outpatient",PSOAR("IN")="Inpatient and Non-VA"
S PSOAR("ON")="Outpatient and Non-VA",PSOAR("ION")="All"
D ASK
I PSOQUIT D QUIT Q
D VER
I PSOQUIT D QUIT Q
;Check for PSODUZ because at this point PSOQUIT might be 0
;if user kept re-answering prompts and cycling through without
;verifying all answers were correct
I PSODUZ]"" D TASK
Q
;
ASK ;
W !!,"NOTE: Because of the potential for journaling or other system"
W !,"issues, you may not want to search large date ranges at one time."
W !,"This search routine limits the search to a year's worth of orders,"
W !,"but that might still be too large of a date range depending on"
W !,"your order volume.",!
S DIR(0)="DO",DIR("A")="Date to begin search"
D ^DIR
I $G(Y)=""!($D(DTOUT))!($D(DUOUT)) S PSOQUIT=1 Q
S PSOSDT=$P(Y,".")
D DD^%DT W ?40,$G(Y)
S DIR(0)="DO",DIR("A")="Date to end search "
D ^DIR
I $G(Y)=""!($D(DTOUT))!($D(DUOUT)) S PSOQUIT=1 Q
S PSOEDT=$P(Y,".")
I PSOSDT>PSOEDT D G ASK
. W !,?5,"The start date cannot be greater than the end date.",!
D DD^%DT W ?40,$G(Y)
I $$FMDIFF^XLFDT(PSOEDT,PSOSDT)>365 D G ASK
. W !!,"A maximum of a year's worth of orders may be searched due to"
. W !,"potential journaling or other system issues."
W !!,"Search Inpatient, Outpatient, Non-VA, or a combination of order types?"
W !,"(IV Medications are included in an Inpatient search.)"
W !,"(""Inpatient"" and ""Outpatient"" refer to the order dialog used,"
W !," not the patient's status.)"
K DIR S DIR(0)="SO^I:"_PSOAR("I")_";O:"_PSOAR("O")_";N:"_PSOAR("N")_";IN:"_PSOAR("IN")
S DIR(0)=DIR(0)_";ON:"_PSOAR("ON")_";A:All"
D ^DIR
I $G(Y)=""!($D(DTOUT))!($D(DUOUT)) S PSOQUIT=1 Q
S PSOTYP=$S(Y="A":"ION",1:Y)
;
W !!,"INSTRUCTIONS FOR NEXT PROMPT"
W !,"============================"
W !!," * If a medication is expired or discontinued in the associated"
W !," medication file (PRESCRIPTION (#52) file or PHARMACY PATIENT (#55) file)"
W !," this routine could correct the ORDERS (#100) file status to expired"
W !," or discontinued if the ORDERS (#100) file status is active."
W !!," * Initially answer the prompt ""Should the status in the ORDERS (#100) file"
W !," be corrected automatically?"" with ""NO"" to let the routine search to see"
W !," how many affected orders exist per date range. Then check a few in CPRS"
W !," and FileMan."
W !!," * After running the search option again and answering the following prompt"
W !," with ""Y"", verify that those orders have been corrected."
W !!,"Should the status in the ORDERS (#100) file"
S DIR(0)="Y",DIR("B")="NO"
S DIR("A")="be corrected automatically"
D ^DIR K DIR
I $D(DTOUT)!($D(DUOUT)) S PSOQUIT=1 Q
S PSOCORR=+Y
Q
;
VER ;
W !!,"PLEASE VERIFY:",!
W !,?5,"Date to begin search: "
S Y=PSOSDT D DD^%DT W ?34,Y
W !,?5,"Date to end search: "
S Y=PSOEDT D DD^%DT W ?34,Y
W !!,?5,"Type(s) of orders to search: ",PSOAR(PSOTYP)
W !!,?5,"ORDERS (#100) file status ",$S(PSOCORR:"*** WILL ***",1:"*** WILL NOT ***")," be corrected automatically.",!
S DIR(0)="Y",DIR("B")="NO"
W ! S DIR("A")="Are these selections correct"
D ^DIR K DIR
I $G(Y)=0 W !! G EN
I $D(DTOUT)!($D(DUOUT)) S PSOQUIT=1 Q
S PSODUZ=DUZ
Q
;
QUIT ;
Q:$D(^TMP("PSOQUIT",$J))
;
;setting ^XTMP("PSOQMSG",$J) since otherwise this message might display twice
;depending on how often user reviewed prompt choices before deciding to quit
;Need to use ^XTMP instead of variable check because user might review multiple times
;^TMP("PSOQUIT",$J) is killed as an "EXIT ACTION" after exiting the option.
;
S ^TMP("PSOQUIT",$J)=""
W !!,"Exiting... Re-enter option if you wish to perform the search."
W !!,"There will be no MailMan message and alert generated"
W !,"due to early termination of this option.",!!
Q
;
TASK ;
S ZTSAVE("PSOSDT")=""
S ZTSAVE("PSOEDT")=""
S ZTSAVE("PSOTYP")=""
S ZTSAVE("PSOCORR")=""
S ZTSAVE("PSODUZ")=""
S ZTSAVE("PSOAR(")=""
S ZTRTN="INIT^PSOUTOR"
S ZTDESC="Medication File(s) Status Search"
S ZTIO=""
D ^%ZTLOAD
W:$D(ZTSK) !!,?5,"Medication File(s) Status Search - TASK NUMBER: ",$G(ZTSK)
W !!,"You will receive an alert and a MailMan message when the search completes.",!
Q
;
INIT ;
N PSOOREXP,PSOORDIS,PSOORDISED,PSOACTIVE,PSORD,PSOSUB,PSODIAL
N PSOOUTP,PSOINPAT,PSIV,PSONONVA,PSOMSTAT
S PSOOREXP=$O(^ORD(100.01,"B","EXPIRED",""))
S PSOORDIS=$O(^ORD(100.01,"B","DISCONTINUED",""))
S PSOORDISED=$O(^ORD(100.01,"B","DISCONTINUED/EDIT",""))
S PSOACTIVE=$O(^ORD(100.01,"B","ACTIVE",""))
I PSOTYP["O" D
. S PSOSUB=$O(^ORD(100.98,"B","OUTPATIENT MEDICATIONS","")) Q:PSOSUB=""
. S PSOOUTP=PSOSUB
. S PSODIAL(PSOSUB)=""
I PSOTYP["I" D
. ;Unknown when "INPATIENT MEDICATIONS" is set vs IV or UD, but setting in array anyway
. F PSORD="INPATIENT MEDICATIONS","IV MEDICATIONS","UNIT DOSE MEDICATIONS" D
. . S PSOSUB=$O(^ORD(100.98,"B",PSORD,"")) Q:PSOSUB=""
. . S PSODIAL(PSOSUB)=""
. . I PSORD="IV MEDICATIONS" S PSIV=PSOSUB Q
. . S PSOINPAT(PSOSUB)=""
I PSOTYP["N" D
. S PSONONVA=$O(^ORD(100.98,"B","NON-VA MEDICATIONS",""))
. I PSONONVA]"" S PSODIAL(PSONONVA)=""
;Set array of Med (#52 or #55) statuses
;(Except for non-VA)
S PSOMSTAT(0)="Active"
S PSOMSTAT(1)="Non-Verified"
S PSOMSTAT(2)="Refill"
S PSOMSTAT(3)="Hold"
S PSOMSTAT(4)="Drug Interactions"
S PSOMSTAT(5)="Suspended"
S PSOMSTAT(10)="Done"
S PSOMSTAT(11)="Expired"
S PSOMSTAT(12)="Discontinued"
S PSOMSTAT(13)="Deleted"
S PSOMSTAT(14)="DC/Provider"
S PSOMSTAT(15)="DC/Edit"
S PSOMSTAT(16)="Provider Hold"
S PSOMSTAT("A")="Active"
S PSOMSTAT("D")="Discontinued"
S PSOMSTAT("DE")="DC/Edit"
S PSOMSTAT("DR")="DC/Renewal"
S PSOMSTAT("H")="Hold"
S PSOMSTAT("E")="Expired"
S PSOMSTAT("R")="Renewed"
S PSOMSTAT("RE")="Reinstated"
S PSOMSTAT("P")="Purge"
S PSOMSTAT("O")="On Call"
S PSOMSTAT("N")="Non Verified"
D SEARCH
Q
;
SEARCH ;
N PSOTMP,X,PSOJOB,PSNUM,PSOORD,PSOORSTAT,PSOPAUSED,PSMSTAT,PSOPAT,PSOA
N PSOSTART,PSOORTYPE,PSOORD,PSOSUBN,PSOSTR,PSOWHICH,PSOMESNUM
N PSOOI,PSOIV,PSOPKG,PSODRUG,PSODATEA,PSODATEB,PSOTX
S PSOTMP="PSOUTOR "_$J
I $D(^XTMP(PSOTMP)) D
. S PSOJOB=$J
. F PSOA=1:1:500 Q:'$D(^XTMP(PSOTMP)) D
. . S PSOJOB=PSOJOB+1
. . S PSOTMP="PSOUTOR "_PSOJOB
;
;not checking to see if the 500th attempt is unused
;surely this routine won't be run 500 times using the
;same job number within 60 days
;
S ^XTMP(PSOTMP,0)=$$FMADD^XLFDT(DT,60)_"^"_DT_"^MEDICATION FILE SEARCH"
;Note: The "A" subscript is necessary because follow-up patch PSO*7.0*599 will
; set another subscript for an additional type of search.
S ^XTMP(PSOTMP,"A")="ORDERS (#100) file status = active / Medication file status not active"
;
;Setting "1" subscript to "No issues found" initially.
S ^XTMP(PSOTMP,"A",1)="No issues found."
;
S PSOA=0,(PSOPAUSED,PSOSTART)=PSOSDT,PSOEDT=PSOEDT+1
S PSOORD=""
F S PSOSDT=$O(^OR(100,"AF",PSOSDT)) Q:PSOSDT>PSOEDT Q:PSOSDT="" D
. ;pause between every 30 days of data
. I PSOPAUSED'=$P(PSOSDT,"."),$E($P(PSOSDT,"."),6,7)#30=0 D
. . H 5 S PSOPAUSED=$P(PSOSDT,".")
. . ;setting "PAUSE" level in case a developer is monitoring the search
. . ;and would like to know how far along the search is
. . S ^XTMP(PSOTMP,"PAUSE")=PSOPAUSED
. F S PSOORD=$O(^OR(100,"AF",PSOSDT,PSOORD)) Q:PSOORD="" D
. . ;
. . ;Quit if this order number has been evaluated in this session
. . ;There can be multiple entries for each order in the "AF" subscript.
. . Q:$D(^XTMP(PSOTMP,"DONE",PSOORD))
. . S ^XTMP(PSOTMP,"DONE",PSOORD)=""
. . ;
. . S PSOORTYPE=$P($G(^OR(100,PSOORD,0)),"^",11) Q:PSOORTYPE=""
. . Q:'$D(PSODIAL(PSOORTYPE))
. . S PSOORSTAT=$P($G(^OR(100,PSOORD,3)),"^",3)
. . ;
. . S PSOPAT=$P($P(^OR(100,PSOORD,0),"^",2),";") Q:'PSOPAT
. . ;
. . ;Non-VA Medications (both Inpatient and Outpatient non-VA meds are stored in file 55)
. . I PSOORTYPE=$G(PSONONVA) D NONVA Q
. . ;Outpatient
. . I PSOORTYPE=$G(PSOOUTP) D OP Q
. . ;IV
. . I PSOORTYPE=$G(PSIV) D IV Q
. . ;Unit Dose
. . I $D(PSOINPAT(PSOORTYPE)) D UD
;
S PSOMESNUM=$$MAIL^PSOUTOR1()
D ALERT,KILL
S ^XTMP(PSOTMP,"FINISHED")=""
Q
;
NONVA ;Non-VA medication order evaluation
S PSNUM=$P($G(^OR(100,PSOORD,4)),"^") Q:PSNUM=""
;
;Package reference for non-VA - numeric plus "N"
S PSOSUBN=$E(PSNUM,1,$L(PSNUM)-1) Q:PSOSUBN=""
S PSOSTR=$G(^PS(55,PSOPAT,"NVA",PSOSUBN,0))
;
;Entry will not yet be in file 55 if pending
;(but also PSNUM will be null -- this is a double check)
Q:PSOSTR=""
;
;Should be only one orderable item per non-VA order
S PSOOI=$G(^OR(100,PSOORD,.1,1,0))
S PSOOI=$P($G(^ORD(101.43,+PSOOI,0)),"^")
S PSOPKG=$G(^OR(100,PSOORD,4))
S PSODATEA=$P(PSOSTR,"^",10)
S PSODRUG=$P(PSOSTR,"^",2)
S PSODRUG=$P($G(^PSDRUG(+PSODRUG,0)),"^")
S PSODATEB=$P(PSOSTR,"^",7)
;PSMSTAT will be null if active
;1=discontinued; 2=date of death entered
S PSMSTAT=$P(PSOSTR,"^",6)
S PSMSTAT=$S(PSMSTAT=2:"DC/Death",PSMSTAT=1:"Discontinued",1:"Active")
;
;Validate active file 100 status against file 55 status
I PSOORSTAT=PSOACTIVE,$E(PSMSTAT)'="A" D
. S PSOA=PSOA+1
. I PSOCORR D FOUND
. D XTMP("A","Non-VA")
Q
;
OP ;Outpatient medication order evaluation
S PSNUM=$P($G(^OR(100,PSOORD,4)),"^") Q:PSNUM=""
;
;Entry will not yet be in file 52 if order is pending
Q:'$D(^PSRX(PSNUM))
;
;should only have one orderable item per outpatient med
S PSOOI=$G(^OR(100,PSOORD,.1,1,0))
S PSOOI=$P($G(^ORD(101.43,+PSOOI,0)),"^")
S PSOPKG=$G(^OR(100,PSOORD,4))
S PSODATEA=$P(^PSRX(PSNUM,0),"^",13)
S PSODRUG=$P(^PSRX(PSNUM,0),"^",6)
S PSODRUG=$P($G(^PSDRUG(+PSODRUG,0)),"^")
S PSODATEB=$P($G(^PSRX(PSNUM,2)),"^",6)
;PRESCRIPTION (#52) File Status codes:
; 11 = Expired
; 12 = Discontinued
; 13 = Deleted
; 14 = Discontinued By Provider
; 15 = Discontinued (Edit)
S PSMSTAT=$G(^PSRX(PSNUM,"STA"))
I PSMSTAT]"" S PSMSTAT=$G(PSOMSTAT(PSMSTAT))
;
;Validate active file 100 status against file 55 status
I PSOORSTAT=PSOACTIVE,($E(PSMSTAT)="E"!($E(PSMSTAT,1,2)="Di")!($E(PSMSTAT,1,2)="De")!($E(PSMSTAT,1,2)="DC")) D
. S PSOA=PSOA+1
. I PSOCORR,($E(PSMSTAT,1,2)="Di"!($E(PSMSTAT)="E")!($E(PSMSTAT,1,2)="De")!($E(PSMSTAT,1,2)="DC")) D FOUND
. D XTMP("A","Outpatient")
Q
;
IV ;IV order search
S PSNUM=$P($G(^OR(100,PSOORD,4)),"^") Q:PSNUM=""
;
S PSOSUBN=$E(PSNUM,1,$L(PSNUM)-1) Q:PSOSUBN=""
S PSOSTR=$G(^PS(55,PSOPAT,"IV",PSOSUBN,0))
;
;PSOSTR will be null if order is pending
Q:PSOSTR=""
;
N PSOX
;partial text on IV components since there can be
;several - enough information is provided enabling
;sites to research
S PSOX=0,(PSOOI,PSOIV)=""
F S PSOX=$O(^OR(100,PSOORD,.1,PSOX)) Q:'PSOX D
. S PSOOI=PSOOI_$S(PSOOI]"":";",1:"")
. S PSOIV=$G(^OR(100,PSOORD,.1,PSOX,0))
. S PSOOI=PSOOI_$P($G(^ORD(101.43,+PSOIV,0)),"^")
S PSOOI=$E(PSOOI,1,14)
S PSOPKG=$G(^OR(100,PSOORD,4))
S PSODATEA=$P(PSOSTR,"^",2)
S PSODRUG=$P($G(^PS(55,PSOPAT,"IV",PSOSUBN,"AD",1,0)),"^")
S PSODRUG=$P($G(^PS(52.6,+PSODRUG,0)),"^")
S PSODATEB=$P(PSOSTR,"^",3)
S PSMSTAT=$P(PSOSTR,"^",17)
I PSMSTAT]"" S PSMSTAT=$G(PSOMSTAT(PSMSTAT))
;
;Validate active file 100 status against file 55 status
I PSOORSTAT=PSOACTIVE,$E(PSMSTAT)'="A" D
. S PSOA=PSOA+1
. I PSOCORR,($E(PSMSTAT)="D"!($E(PSMSTAT)="E")) D FOUND
. D XTMP("A","IV")
Q
;
UD ;Inpatient (unit dose) order search
S PSNUM=$P($G(^OR(100,PSOORD,4)),"^") Q:PSNUM=""
;
;Years ago, IV orders were filed under the Unit Dose display group
;If an IV order, display under the IV section of the MailMan message.
I $E(PSNUM,$L(PSNUM))="V" D IV
Q:$E(PSNUM,$L(PSNUM))="V"
S PSOSUBN=$E(PSNUM,1,$L(PSNUM)-1) Q:PSOSUBN=""
S PSOSTR=$G(^PS(55,PSOPAT,5,PSOSUBN,0))
;
;PSOSTR will be null if order is pending
Q:PSOSTR=""
;
;There might be multiple OI's, but just get the first one.
;User then has enough information to research the order.
S PSOOI=$G(^OR(100,PSOORD,.1,1,0))
S PSOOI=$P($G(^ORD(101.43,+PSOOI,0)),"^")
S PSOPKG=$G(^OR(100,PSOORD,4))
S PSODATEA=$P($G(^PS(55,PSOPAT,5,PSOSUBN,2)),"^",2)
;Retrieve the last dispense drug.
S PSODRUG=$P($G(^PS(55,PSOPAT,5,PSOSUBN,1,0)),"^",3)
S PSODRUG=$P($G(^PS(55,PSOPAT,5,PSOSUBN,1,+PSODRUG,0)),"^")
S PSODRUG=$P($G(^PSDRUG(+PSODRUG,0)),"^")
S PSODATEB=$P($G(^PS(55,PSOPAT,5,PSOSUBN,2)),"^",4)
S PSMSTAT=$P(PSOSTR,"^",9)
I PSMSTAT]"" S PSMSTAT=$G(PSOMSTAT(PSMSTAT))
;
;Validate active file 100 status against file 55 status
I PSOORSTAT=PSOACTIVE,$E(PSMSTAT)'="A" D
. S PSOA=PSOA+1
. I PSOCORR,($E(PSMSTAT)="D"!($E(PSMSTAT)="E")) D FOUND
. D XTMP("A","Unit Dose")
Q
;
FOUND ;
;This section is only called if the Order (#100) status is active,
;the associated med (#52 or #55) status is expired or discontinued
;and the user specified that the order status should be updated.
;PSMSTAT = status of Med (#52 or #55) file
;PSOSTAT = which corresponding status should the Order (#100) entry
; be set to
N PSOSTAT
S PSOSTAT=$S($E(PSMSTAT)="E":PSOOREXP,1:PSOORDIS)
D STATUS^ORCSAVE2(PSOORD,PSOSTAT)
Q
;
XTMP(PSOTX,PSOWHICH) ;
;PSOORDTM = WHEN ENTERED (#4) field from the Order (#100) file
N PSOORDTM,PSOSTATX
S PSOORDTM=$P(^OR(100,+PSOORD,0),"^",7)
S PSOSTATX=$P($G(^ORD(100.01,+PSOORSTAT,0)),"^")
S ^XTMP(PSOTMP,PSOTX,PSOWHICH,PSOORD)=$S(PSOTX'="A":"",PSOCORR:"fixed",1:"")_"^"_$$FMTE^XLFDT(PSOORDTM)_"^"_PSOOI_"^"
S ^XTMP(PSOTMP,PSOTX,PSOWHICH,PSOORD)=^XTMP(PSOTMP,PSOTX,PSOWHICH,PSOORD)_PSOSTATX_"^"_PSOPKG_"^"_$$FMTE^XLFDT(PSODATEA)_"^"
S ^XTMP(PSOTMP,PSOTX,PSOWHICH,PSOORD)=^XTMP(PSOTMP,PSOTX,PSOWHICH,PSOORD)_PSODRUG_"^"_PSMSTAT_"^"_$$FMTE^XLFDT(PSODATEB)
Q
;
ALERT ;
;variables must be prefixed with "X"
N XQAID,XALERT
S (XQAID,XQAMSG)="Medication file search: "_$S(PSOA:"A",1:"No a")
S XQAMSG=XQAMSG_"ffected order(s)"_" found. Message #:"_PSOMESNUM
S XQA(PSODUZ)=""
S XALERT=$$SETUP1^XQALERT
Q
;
KILL ;
K ^XTMP(PSOTMP,"PAUSE")
;gradually kill in case this file is huge
N PSOCOUNT,PSOORD
S PSOCOUNT=0,PSOORD=""
F S PSOORD=$O(^XTMP(PSOTMP,"DONE",PSOORD)) Q:PSOORD="" D
. S PSOCOUNT=PSOCOUNT+1
. H:PSOCOUNT#10000=0 20
. K ^XTMP(PSOTMP,"DONE",PSOORD)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOUTOR 16320 printed Sep 23, 2025@20:12:36 Page 2
PSOUTOR ;HPS/DSK - MEDICATION ORDER STATUS CHECK; Oct 22, 2024@10:20
+1 ;;7.0;OUTPATIENT PHARMACY;**546,775**;DEC 1997;Build 1
+2 ;
+3 ;Reference to: Supported by:
+4 ;------------- -------------
+5 ;^OR(100 IA #3582
+6 ;DISPLAY GROUP (#100.98) file IA #873
+7 ;ORDER STATUS (#100.01) file IA #875
+8 ;ORDERABLE ITEMS (#101.43) file IA #5430
+9 ;DRUG (#50) file IA #221
+10 ;PHARMACY PATIENT (#55) file IA #6987
+11 ;^XLFDT IA #10103
+12 ;DD^%DT IA #10003
+13 ;NOW^%DTC IA #10000
+14 ;^%ZTLOAD IA #10063
+15 ;STATUS^ORCSAVE2 IA #5903
+16 ;$$SETUP1^XQALERT IA #10081
+17 ;NOTE: SACC guidelines allow lowercase subscripts in ^TMP and ^XTMP.
+18 ;
+19 ;PSO*7.0*775: Deleted requirement that start date precede login date
+20 ; of first IEN in the ORDERS (#100) file. The lowest IEN
+21 ; may not necessarily correspond to the install of CPRS.
+22 ;
+23 ;Search Logic
+24 ;============
+25 ;
+26 ;This routine searches for discontinued medication orders with discontinued
+27 ;or expired statuses which are still active in the ORDERS (#100) file.
+28 ;
+29 ;^XTMP Subscript Logic
+30 ;=====================
+31 ;
+32 ;Subscripts in ^XTMP are set with verbiage that will aid anyone who reviews the search
+33 ;results as to the issues which were found. Data is kept in ^XTMP for 60 days.
+34 ;
+35 ;MailMan Message / Alert Logic
+36 ;=============================
+37 ;
+38 ;MailMan messages and an alert are generated to the user who invoked the search option.
+39 ;
+40 QUIT
+41 ;
EN ;Status Mismatch Search
+1 NEW DIR,DTOUT,DUOUT,Y,PSOQUIT,PSOSDT,PSOEDT,PSOTYP,PSOCORR,PSOVER,PSODUZ,PSOAR
+2 SET PSOQUIT=0
SET PSODUZ=""
+3 ;
+4 ;PSOAR used for user display and MailMan messaging
+5 SET PSOAR("I")="Inpatient"
SET PSOAR("O")="Outpatient"
SET PSOAR("N")="Non-VA"
+6 SET PSOAR("IO")="Inpatient and Outpatient"
SET PSOAR("IN")="Inpatient and Non-VA"
+7 SET PSOAR("ON")="Outpatient and Non-VA"
SET PSOAR("ION")="All"
+8 DO ASK
+9 IF PSOQUIT
DO QUIT
QUIT
+10 DO VER
+11 IF PSOQUIT
DO QUIT
QUIT
+12 ;Check for PSODUZ because at this point PSOQUIT might be 0
+13 ;if user kept re-answering prompts and cycling through without
+14 ;verifying all answers were correct
+15 IF PSODUZ]""
DO TASK
+16 QUIT
+17 ;
ASK ;
+1 WRITE !!,"NOTE: Because of the potential for journaling or other system"
+2 WRITE !,"issues, you may not want to search large date ranges at one time."
+3 WRITE !,"This search routine limits the search to a year's worth of orders,"
+4 WRITE !,"but that might still be too large of a date range depending on"
+5 WRITE !,"your order volume.",!
+6 SET DIR(0)="DO"
SET DIR("A")="Date to begin search"
+7 DO ^DIR
+8 IF $GET(Y)=""!($DATA(DTOUT))!($DATA(DUOUT))
SET PSOQUIT=1
QUIT
+9 SET PSOSDT=$PIECE(Y,".")
+10 DO DD^%DT
WRITE ?40,$GET(Y)
+11 SET DIR(0)="DO"
SET DIR("A")="Date to end search "
+12 DO ^DIR
+13 IF $GET(Y)=""!($DATA(DTOUT))!($DATA(DUOUT))
SET PSOQUIT=1
QUIT
+14 SET PSOEDT=$PIECE(Y,".")
+15 IF PSOSDT>PSOEDT
Begin DoDot:1
+16 WRITE !,?5,"The start date cannot be greater than the end date.",!
End DoDot:1
GOTO ASK
+17 DO DD^%DT
WRITE ?40,$GET(Y)
+18 IF $$FMDIFF^XLFDT(PSOEDT,PSOSDT)>365
Begin DoDot:1
+19 WRITE !!,"A maximum of a year's worth of orders may be searched due to"
+20 WRITE !,"potential journaling or other system issues."
End DoDot:1
GOTO ASK
+21 WRITE !!,"Search Inpatient, Outpatient, Non-VA, or a combination of order types?"
+22 WRITE !,"(IV Medications are included in an Inpatient search.)"
+23 WRITE !,"(""Inpatient"" and ""Outpatient"" refer to the order dialog used,"
+24 WRITE !," not the patient's status.)"
+25 KILL DIR
SET DIR(0)="SO^I:"_PSOAR("I")_";O:"_PSOAR("O")_";N:"_PSOAR("N")_";IN:"_PSOAR("IN")
+26 SET DIR(0)=DIR(0)_";ON:"_PSOAR("ON")_";A:All"
+27 DO ^DIR
+28 IF $GET(Y)=""!($DATA(DTOUT))!($DATA(DUOUT))
SET PSOQUIT=1
QUIT
+29 SET PSOTYP=$SELECT(Y="A":"ION",1:Y)
+30 ;
+31 WRITE !!,"INSTRUCTIONS FOR NEXT PROMPT"
+32 WRITE !,"============================"
+33 WRITE !!," * If a medication is expired or discontinued in the associated"
+34 WRITE !," medication file (PRESCRIPTION (#52) file or PHARMACY PATIENT (#55) file)"
+35 WRITE !," this routine could correct the ORDERS (#100) file status to expired"
+36 WRITE !," or discontinued if the ORDERS (#100) file status is active."
+37 WRITE !!," * Initially answer the prompt ""Should the status in the ORDERS (#100) file"
+38 WRITE !," be corrected automatically?"" with ""NO"" to let the routine search to see"
+39 WRITE !," how many affected orders exist per date range. Then check a few in CPRS"
+40 WRITE !," and FileMan."
+41 WRITE !!," * After running the search option again and answering the following prompt"
+42 WRITE !," with ""Y"", verify that those orders have been corrected."
+43 WRITE !!,"Should the status in the ORDERS (#100) file"
+44 SET DIR(0)="Y"
SET DIR("B")="NO"
+45 SET DIR("A")="be corrected automatically"
+46 DO ^DIR
KILL DIR
+47 IF $DATA(DTOUT)!($DATA(DUOUT))
SET PSOQUIT=1
QUIT
+48 SET PSOCORR=+Y
+49 QUIT
+50 ;
VER ;
+1 WRITE !!,"PLEASE VERIFY:",!
+2 WRITE !,?5,"Date to begin search: "
+3 SET Y=PSOSDT
DO DD^%DT
WRITE ?34,Y
+4 WRITE !,?5,"Date to end search: "
+5 SET Y=PSOEDT
DO DD^%DT
WRITE ?34,Y
+6 WRITE !!,?5,"Type(s) of orders to search: ",PSOAR(PSOTYP)
+7 WRITE !!,?5,"ORDERS (#100) file status ",$SELECT(PSOCORR:"*** WILL ***",1:"*** WILL NOT ***")," be corrected automatically.",!
+8 SET DIR(0)="Y"
SET DIR("B")="NO"
+9 WRITE !
SET DIR("A")="Are these selections correct"
+10 DO ^DIR
KILL DIR
+11 IF $GET(Y)=0
WRITE !!
GOTO EN
+12 IF $DATA(DTOUT)!($DATA(DUOUT))
SET PSOQUIT=1
QUIT
+13 SET PSODUZ=DUZ
+14 QUIT
+15 ;
QUIT ;
+1 if $DATA(^TMP("PSOQUIT",$JOB))
QUIT
+2 ;
+3 ;setting ^XTMP("PSOQMSG",$J) since otherwise this message might display twice
+4 ;depending on how often user reviewed prompt choices before deciding to quit
+5 ;Need to use ^XTMP instead of variable check because user might review multiple times
+6 ;^TMP("PSOQUIT",$J) is killed as an "EXIT ACTION" after exiting the option.
+7 ;
+8 SET ^TMP("PSOQUIT",$JOB)=""
+9 WRITE !!,"Exiting... Re-enter option if you wish to perform the search."
+10 WRITE !!,"There will be no MailMan message and alert generated"
+11 WRITE !,"due to early termination of this option.",!!
+12 QUIT
+13 ;
TASK ;
+1 SET ZTSAVE("PSOSDT")=""
+2 SET ZTSAVE("PSOEDT")=""
+3 SET ZTSAVE("PSOTYP")=""
+4 SET ZTSAVE("PSOCORR")=""
+5 SET ZTSAVE("PSODUZ")=""
+6 SET ZTSAVE("PSOAR(")=""
+7 SET ZTRTN="INIT^PSOUTOR"
+8 SET ZTDESC="Medication File(s) Status Search"
+9 SET ZTIO=""
+10 DO ^%ZTLOAD
+11 if $DATA(ZTSK)
WRITE !!,?5,"Medication File(s) Status Search - TASK NUMBER: ",$GET(ZTSK)
+12 WRITE !!,"You will receive an alert and a MailMan message when the search completes.",!
+13 QUIT
+14 ;
INIT ;
+1 NEW PSOOREXP,PSOORDIS,PSOORDISED,PSOACTIVE,PSORD,PSOSUB,PSODIAL
+2 NEW PSOOUTP,PSOINPAT,PSIV,PSONONVA,PSOMSTAT
+3 SET PSOOREXP=$ORDER(^ORD(100.01,"B","EXPIRED",""))
+4 SET PSOORDIS=$ORDER(^ORD(100.01,"B","DISCONTINUED",""))
+5 SET PSOORDISED=$ORDER(^ORD(100.01,"B","DISCONTINUED/EDIT",""))
+6 SET PSOACTIVE=$ORDER(^ORD(100.01,"B","ACTIVE",""))
+7 IF PSOTYP["O"
Begin DoDot:1
+8 SET PSOSUB=$ORDER(^ORD(100.98,"B","OUTPATIENT MEDICATIONS",""))
if PSOSUB=""
QUIT
+9 SET PSOOUTP=PSOSUB
+10 SET PSODIAL(PSOSUB)=""
End DoDot:1
+11 IF PSOTYP["I"
Begin DoDot:1
+12 ;Unknown when "INPATIENT MEDICATIONS" is set vs IV or UD, but setting in array anyway
+13 FOR PSORD="INPATIENT MEDICATIONS","IV MEDICATIONS","UNIT DOSE MEDICATIONS"
Begin DoDot:2
+14 SET PSOSUB=$ORDER(^ORD(100.98,"B",PSORD,""))
if PSOSUB=""
QUIT
+15 SET PSODIAL(PSOSUB)=""
+16 IF PSORD="IV MEDICATIONS"
SET PSIV=PSOSUB
QUIT
+17 SET PSOINPAT(PSOSUB)=""
End DoDot:2
End DoDot:1
+18 IF PSOTYP["N"
Begin DoDot:1
+19 SET PSONONVA=$ORDER(^ORD(100.98,"B","NON-VA MEDICATIONS",""))
+20 IF PSONONVA]""
SET PSODIAL(PSONONVA)=""
End DoDot:1
+21 ;Set array of Med (#52 or #55) statuses
+22 ;(Except for non-VA)
+23 SET PSOMSTAT(0)="Active"
+24 SET PSOMSTAT(1)="Non-Verified"
+25 SET PSOMSTAT(2)="Refill"
+26 SET PSOMSTAT(3)="Hold"
+27 SET PSOMSTAT(4)="Drug Interactions"
+28 SET PSOMSTAT(5)="Suspended"
+29 SET PSOMSTAT(10)="Done"
+30 SET PSOMSTAT(11)="Expired"
+31 SET PSOMSTAT(12)="Discontinued"
+32 SET PSOMSTAT(13)="Deleted"
+33 SET PSOMSTAT(14)="DC/Provider"
+34 SET PSOMSTAT(15)="DC/Edit"
+35 SET PSOMSTAT(16)="Provider Hold"
+36 SET PSOMSTAT("A")="Active"
+37 SET PSOMSTAT("D")="Discontinued"
+38 SET PSOMSTAT("DE")="DC/Edit"
+39 SET PSOMSTAT("DR")="DC/Renewal"
+40 SET PSOMSTAT("H")="Hold"
+41 SET PSOMSTAT("E")="Expired"
+42 SET PSOMSTAT("R")="Renewed"
+43 SET PSOMSTAT("RE")="Reinstated"
+44 SET PSOMSTAT("P")="Purge"
+45 SET PSOMSTAT("O")="On Call"
+46 SET PSOMSTAT("N")="Non Verified"
+47 DO SEARCH
+48 QUIT
+49 ;
SEARCH ;
+1 NEW PSOTMP,X,PSOJOB,PSNUM,PSOORD,PSOORSTAT,PSOPAUSED,PSMSTAT,PSOPAT,PSOA
+2 NEW PSOSTART,PSOORTYPE,PSOORD,PSOSUBN,PSOSTR,PSOWHICH,PSOMESNUM
+3 NEW PSOOI,PSOIV,PSOPKG,PSODRUG,PSODATEA,PSODATEB,PSOTX
+4 SET PSOTMP="PSOUTOR "_$JOB
+5 IF $DATA(^XTMP(PSOTMP))
Begin DoDot:1
+6 SET PSOJOB=$JOB
+7 FOR PSOA=1:1:500
if '$DATA(^XTMP(PSOTMP))
QUIT
Begin DoDot:2
+8 SET PSOJOB=PSOJOB+1
+9 SET PSOTMP="PSOUTOR "_PSOJOB
End DoDot:2
End DoDot:1
+10 ;
+11 ;not checking to see if the 500th attempt is unused
+12 ;surely this routine won't be run 500 times using the
+13 ;same job number within 60 days
+14 ;
+15 SET ^XTMP(PSOTMP,0)=$$FMADD^XLFDT(DT,60)_"^"_DT_"^MEDICATION FILE SEARCH"
+16 ;Note: The "A" subscript is necessary because follow-up patch PSO*7.0*599 will
+17 ; set another subscript for an additional type of search.
+18 SET ^XTMP(PSOTMP,"A")="ORDERS (#100) file status = active / Medication file status not active"
+19 ;
+20 ;Setting "1" subscript to "No issues found" initially.
+21 SET ^XTMP(PSOTMP,"A",1)="No issues found."
+22 ;
+23 SET PSOA=0
SET (PSOPAUSED,PSOSTART)=PSOSDT
SET PSOEDT=PSOEDT+1
+24 SET PSOORD=""
+25 FOR
SET PSOSDT=$ORDER(^OR(100,"AF",PSOSDT))
if PSOSDT>PSOEDT
QUIT
if PSOSDT=""
QUIT
Begin DoDot:1
+26 ;pause between every 30 days of data
+27 IF PSOPAUSED'=$PIECE(PSOSDT,".")
IF $EXTRACT($PIECE(PSOSDT,"."),6,7)#30=0
Begin DoDot:2
+28 HANG 5
SET PSOPAUSED=$PIECE(PSOSDT,".")
+29 ;setting "PAUSE" level in case a developer is monitoring the search
+30 ;and would like to know how far along the search is
+31 SET ^XTMP(PSOTMP,"PAUSE")=PSOPAUSED
End DoDot:2
+32 FOR
SET PSOORD=$ORDER(^OR(100,"AF",PSOSDT,PSOORD))
if PSOORD=""
QUIT
Begin DoDot:2
+33 ;
+34 ;Quit if this order number has been evaluated in this session
+35 ;There can be multiple entries for each order in the "AF" subscript.
+36 if $DATA(^XTMP(PSOTMP,"DONE",PSOORD))
QUIT
+37 SET ^XTMP(PSOTMP,"DONE",PSOORD)=""
+38 ;
+39 SET PSOORTYPE=$PIECE($GET(^OR(100,PSOORD,0)),"^",11)
if PSOORTYPE=""
QUIT
+40 if '$DATA(PSODIAL(PSOORTYPE))
QUIT
+41 SET PSOORSTAT=$PIECE($GET(^OR(100,PSOORD,3)),"^",3)
+42 ;
+43 SET PSOPAT=$PIECE($PIECE(^OR(100,PSOORD,0),"^",2),";")
if 'PSOPAT
QUIT
+44 ;
+45 ;Non-VA Medications (both Inpatient and Outpatient non-VA meds are stored in file 55)
+46 IF PSOORTYPE=$GET(PSONONVA)
DO NONVA
QUIT
+47 ;Outpatient
+48 IF PSOORTYPE=$GET(PSOOUTP)
DO OP
QUIT
+49 ;IV
+50 IF PSOORTYPE=$GET(PSIV)
DO IV
QUIT
+51 ;Unit Dose
+52 IF $DATA(PSOINPAT(PSOORTYPE))
DO UD
End DoDot:2
End DoDot:1
+53 ;
+54 SET PSOMESNUM=$$MAIL^PSOUTOR1()
+55 DO ALERT
DO KILL
+56 SET ^XTMP(PSOTMP,"FINISHED")=""
+57 QUIT
+58 ;
NONVA ;Non-VA medication order evaluation
+1 SET PSNUM=$PIECE($GET(^OR(100,PSOORD,4)),"^")
if PSNUM=""
QUIT
+2 ;
+3 ;Package reference for non-VA - numeric plus "N"
+4 SET PSOSUBN=$EXTRACT(PSNUM,1,$LENGTH(PSNUM)-1)
if PSOSUBN=""
QUIT
+5 SET PSOSTR=$GET(^PS(55,PSOPAT,"NVA",PSOSUBN,0))
+6 ;
+7 ;Entry will not yet be in file 55 if pending
+8 ;(but also PSNUM will be null -- this is a double check)
+9 if PSOSTR=""
QUIT
+10 ;
+11 ;Should be only one orderable item per non-VA order
+12 SET PSOOI=$GET(^OR(100,PSOORD,.1,1,0))
+13 SET PSOOI=$PIECE($GET(^ORD(101.43,+PSOOI,0)),"^")
+14 SET PSOPKG=$GET(^OR(100,PSOORD,4))
+15 SET PSODATEA=$PIECE(PSOSTR,"^",10)
+16 SET PSODRUG=$PIECE(PSOSTR,"^",2)
+17 SET PSODRUG=$PIECE($GET(^PSDRUG(+PSODRUG,0)),"^")
+18 SET PSODATEB=$PIECE(PSOSTR,"^",7)
+19 ;PSMSTAT will be null if active
+20 ;1=discontinued; 2=date of death entered
+21 SET PSMSTAT=$PIECE(PSOSTR,"^",6)
+22 SET PSMSTAT=$SELECT(PSMSTAT=2:"DC/Death",PSMSTAT=1:"Discontinued",1:"Active")
+23 ;
+24 ;Validate active file 100 status against file 55 status
+25 IF PSOORSTAT=PSOACTIVE
IF $EXTRACT(PSMSTAT)'="A"
Begin DoDot:1
+26 SET PSOA=PSOA+1
+27 IF PSOCORR
DO FOUND
+28 DO XTMP("A","Non-VA")
End DoDot:1
+29 QUIT
+30 ;
OP ;Outpatient medication order evaluation
+1 SET PSNUM=$PIECE($GET(^OR(100,PSOORD,4)),"^")
if PSNUM=""
QUIT
+2 ;
+3 ;Entry will not yet be in file 52 if order is pending
+4 if '$DATA(^PSRX(PSNUM))
QUIT
+5 ;
+6 ;should only have one orderable item per outpatient med
+7 SET PSOOI=$GET(^OR(100,PSOORD,.1,1,0))
+8 SET PSOOI=$PIECE($GET(^ORD(101.43,+PSOOI,0)),"^")
+9 SET PSOPKG=$GET(^OR(100,PSOORD,4))
+10 SET PSODATEA=$PIECE(^PSRX(PSNUM,0),"^",13)
+11 SET PSODRUG=$PIECE(^PSRX(PSNUM,0),"^",6)
+12 SET PSODRUG=$PIECE($GET(^PSDRUG(+PSODRUG,0)),"^")
+13 SET PSODATEB=$PIECE($GET(^PSRX(PSNUM,2)),"^",6)
+14 ;PRESCRIPTION (#52) File Status codes:
+15 ; 11 = Expired
+16 ; 12 = Discontinued
+17 ; 13 = Deleted
+18 ; 14 = Discontinued By Provider
+19 ; 15 = Discontinued (Edit)
+20 SET PSMSTAT=$GET(^PSRX(PSNUM,"STA"))
+21 IF PSMSTAT]""
SET PSMSTAT=$GET(PSOMSTAT(PSMSTAT))
+22 ;
+23 ;Validate active file 100 status against file 55 status
+24 IF PSOORSTAT=PSOACTIVE
IF ($EXTRACT(PSMSTAT)="E"!($EXTRACT(PSMSTAT,1,2)="Di")!($EXTRACT(PSMSTAT,1,2)="De")!($EXTRACT(PSMSTAT,1,2)="DC"))
Begin DoDot:1
+25 SET PSOA=PSOA+1
+26 IF PSOCORR
IF ($EXTRACT(PSMSTAT,1,2)="Di"!($EXTRACT(PSMSTAT)="E")!($EXTRACT(PSMSTAT,1,2)="De")!($EXTRACT(PSMSTAT,1,2)="DC"))
DO FOUND
+27 DO XTMP("A","Outpatient")
End DoDot:1
+28 QUIT
+29 ;
IV ;IV order search
+1 SET PSNUM=$PIECE($GET(^OR(100,PSOORD,4)),"^")
if PSNUM=""
QUIT
+2 ;
+3 SET PSOSUBN=$EXTRACT(PSNUM,1,$LENGTH(PSNUM)-1)
if PSOSUBN=""
QUIT
+4 SET PSOSTR=$GET(^PS(55,PSOPAT,"IV",PSOSUBN,0))
+5 ;
+6 ;PSOSTR will be null if order is pending
+7 if PSOSTR=""
QUIT
+8 ;
+9 NEW PSOX
+10 ;partial text on IV components since there can be
+11 ;several - enough information is provided enabling
+12 ;sites to research
+13 SET PSOX=0
SET (PSOOI,PSOIV)=""
+14 FOR
SET PSOX=$ORDER(^OR(100,PSOORD,.1,PSOX))
if 'PSOX
QUIT
Begin DoDot:1
+15 SET PSOOI=PSOOI_$SELECT(PSOOI]"":";",1:"")
+16 SET PSOIV=$GET(^OR(100,PSOORD,.1,PSOX,0))
+17 SET PSOOI=PSOOI_$PIECE($GET(^ORD(101.43,+PSOIV,0)),"^")
End DoDot:1
+18 SET PSOOI=$EXTRACT(PSOOI,1,14)
+19 SET PSOPKG=$GET(^OR(100,PSOORD,4))
+20 SET PSODATEA=$PIECE(PSOSTR,"^",2)
+21 SET PSODRUG=$PIECE($GET(^PS(55,PSOPAT,"IV",PSOSUBN,"AD",1,0)),"^")
+22 SET PSODRUG=$PIECE($GET(^PS(52.6,+PSODRUG,0)),"^")
+23 SET PSODATEB=$PIECE(PSOSTR,"^",3)
+24 SET PSMSTAT=$PIECE(PSOSTR,"^",17)
+25 IF PSMSTAT]""
SET PSMSTAT=$GET(PSOMSTAT(PSMSTAT))
+26 ;
+27 ;Validate active file 100 status against file 55 status
+28 IF PSOORSTAT=PSOACTIVE
IF $EXTRACT(PSMSTAT)'="A"
Begin DoDot:1
+29 SET PSOA=PSOA+1
+30 IF PSOCORR
IF ($EXTRACT(PSMSTAT)="D"!($EXTRACT(PSMSTAT)="E"))
DO FOUND
+31 DO XTMP("A","IV")
End DoDot:1
+32 QUIT
+33 ;
UD ;Inpatient (unit dose) order search
+1 SET PSNUM=$PIECE($GET(^OR(100,PSOORD,4)),"^")
if PSNUM=""
QUIT
+2 ;
+3 ;Years ago, IV orders were filed under the Unit Dose display group
+4 ;If an IV order, display under the IV section of the MailMan message.
+5 IF $EXTRACT(PSNUM,$LENGTH(PSNUM))="V"
DO IV
+6 if $EXTRACT(PSNUM,$LENGTH(PSNUM))="V"
QUIT
+7 SET PSOSUBN=$EXTRACT(PSNUM,1,$LENGTH(PSNUM)-1)
if PSOSUBN=""
QUIT
+8 SET PSOSTR=$GET(^PS(55,PSOPAT,5,PSOSUBN,0))
+9 ;
+10 ;PSOSTR will be null if order is pending
+11 if PSOSTR=""
QUIT
+12 ;
+13 ;There might be multiple OI's, but just get the first one.
+14 ;User then has enough information to research the order.
+15 SET PSOOI=$GET(^OR(100,PSOORD,.1,1,0))
+16 SET PSOOI=$PIECE($GET(^ORD(101.43,+PSOOI,0)),"^")
+17 SET PSOPKG=$GET(^OR(100,PSOORD,4))
+18 SET PSODATEA=$PIECE($GET(^PS(55,PSOPAT,5,PSOSUBN,2)),"^",2)
+19 ;Retrieve the last dispense drug.
+20 SET PSODRUG=$PIECE($GET(^PS(55,PSOPAT,5,PSOSUBN,1,0)),"^",3)
+21 SET PSODRUG=$PIECE($GET(^PS(55,PSOPAT,5,PSOSUBN,1,+PSODRUG,0)),"^")
+22 SET PSODRUG=$PIECE($GET(^PSDRUG(+PSODRUG,0)),"^")
+23 SET PSODATEB=$PIECE($GET(^PS(55,PSOPAT,5,PSOSUBN,2)),"^",4)
+24 SET PSMSTAT=$PIECE(PSOSTR,"^",9)
+25 IF PSMSTAT]""
SET PSMSTAT=$GET(PSOMSTAT(PSMSTAT))
+26 ;
+27 ;Validate active file 100 status against file 55 status
+28 IF PSOORSTAT=PSOACTIVE
IF $EXTRACT(PSMSTAT)'="A"
Begin DoDot:1
+29 SET PSOA=PSOA+1
+30 IF PSOCORR
IF ($EXTRACT(PSMSTAT)="D"!($EXTRACT(PSMSTAT)="E"))
DO FOUND
+31 DO XTMP("A","Unit Dose")
End DoDot:1
+32 QUIT
+33 ;
FOUND ;
+1 ;This section is only called if the Order (#100) status is active,
+2 ;the associated med (#52 or #55) status is expired or discontinued
+3 ;and the user specified that the order status should be updated.
+4 ;PSMSTAT = status of Med (#52 or #55) file
+5 ;PSOSTAT = which corresponding status should the Order (#100) entry
+6 ; be set to
+7 NEW PSOSTAT
+8 SET PSOSTAT=$SELECT($EXTRACT(PSMSTAT)="E":PSOOREXP,1:PSOORDIS)
+9 DO STATUS^ORCSAVE2(PSOORD,PSOSTAT)
+10 QUIT
+11 ;
XTMP(PSOTX,PSOWHICH) ;
+1 ;PSOORDTM = WHEN ENTERED (#4) field from the Order (#100) file
+2 NEW PSOORDTM,PSOSTATX
+3 SET PSOORDTM=$PIECE(^OR(100,+PSOORD,0),"^",7)
+4 SET PSOSTATX=$PIECE($GET(^ORD(100.01,+PSOORSTAT,0)),"^")
+5 SET ^XTMP(PSOTMP,PSOTX,PSOWHICH,PSOORD)=$SELECT(PSOTX'="A":"",PSOCORR:"fixed",1:"")_"^"_$$FMTE^XLFDT(PSOORDTM)_"^"_PSOOI_"^"
+6 SET ^XTMP(PSOTMP,PSOTX,PSOWHICH,PSOORD)=^XTMP(PSOTMP,PSOTX,PSOWHICH,PSOORD)_PSOSTATX_"^"_PSOPKG_"^"_$$FMTE^XLFDT(PSODATEA)_"^"
+7 SET ^XTMP(PSOTMP,PSOTX,PSOWHICH,PSOORD)=^XTMP(PSOTMP,PSOTX,PSOWHICH,PSOORD)_PSODRUG_"^"_PSMSTAT_"^"_$$FMTE^XLFDT(PSODATEB)
+8 QUIT
+9 ;
ALERT ;
+1 ;variables must be prefixed with "X"
+2 NEW XQAID,XALERT
+3 SET (XQAID,XQAMSG)="Medication file search: "_$SELECT(PSOA:"A",1:"No a")
+4 SET XQAMSG=XQAMSG_"ffected order(s)"_" found. Message #:"_PSOMESNUM
+5 SET XQA(PSODUZ)=""
+6 SET XALERT=$$SETUP1^XQALERT
+7 QUIT
+8 ;
KILL ;
+1 KILL ^XTMP(PSOTMP,"PAUSE")
+2 ;gradually kill in case this file is huge
+3 NEW PSOCOUNT,PSOORD
+4 SET PSOCOUNT=0
SET PSOORD=""
+5 FOR
SET PSOORD=$ORDER(^XTMP(PSOTMP,"DONE",PSOORD))
if PSOORD=""
QUIT
Begin DoDot:1
+6 SET PSOCOUNT=PSOCOUNT+1
+7 if PSOCOUNT#10000=0
HANG 20
+8 KILL ^XTMP(PSOTMP,"DONE",PSOORD)
End DoDot:1
+9 QUIT
+10 ;
