PSOAUTOC ;BIR/SAB - auto cancel rxs on admission ;Jan 10, 2022@11:14:59
;;7.0;OUTPATIENT PHARMACY;**3,24,30,36,88,146,132,223,148,249,324,251,332,441**;DEC 1997;Build 208
;External reference to File #59.7 supported by DBIA 694
;External reference to File #55 supported by DBIA 2228
;External reference ^DPT(PSODFN,.1) supported by DBIA 10035
;External reference ^DGPM("AMV1" supported by DBIA 2249
;External reference ^DGPM("APTT1" supported by DBIA 2249
;External reference ^PSDRUG( supported by DBIA 221
;External reference ^PS(50.7 supported by DBIA 2223
;External reference ^XUSEC( supported by IA 10076
;External refernece GOTLOCAL^XMXAPIG supported by IA 3006
AUTO I '$P(^PS(59.7,1,40.1),"^") W $C(7),!,"Auto cancel System Parameter must be set to 'YES'",!,"before prescriptions are discontinued."
K %DT,DIC S DIC(0)="XZM",(DIE,DIC)="^DIC(19.2,",X="PSO AUTOCANCEL" D ^DIC
I +Y>0 D EDIT^XUTMOPT("PSO AUTOCANCEL") G EX
D RESCH^XUTMOPT("PSO AUTOCANCEL","","","24H","L"),EDIT^XUTMOPT("PSO AUTOCANCEL")
EX K Y,C,D,D0,DI,DQ,DA,DIE,DR,DIC,X
Q
TASK ;TaskMan entry point
G:'$P(^PS(59.7,1,40.1),"^") KILL S X="T-3" D ^%DT S PSOD2=Y,PSOD0=Y-.01,PSODL=Y+.3
S PSOD=PSOD0 F S PSOD=$O(^DGPM("AMV1",PSOD)),PSODFN=0 Q:'PSOD!(PSOD>PSODL) F PSODFN=0:0 S PSODFN=$O(^DGPM("AMV1",PSOD,PSODFN)) Q:'PSODFN I $G(^DPT(PSODFN,.1))]"",$O(^PS(55,PSODFN,"P",0)),'$O(^DGPM("APTT1",PSODFN,PSOD)) D CAN
G KILL
CAN ;discontinue Rxs
S DFN=PSODFN K VAIN D INP^VADPT I $P($G(VAIN(4)),"^"),$D(^PS(59.7,1,40.19,"B",$P($G(VAIN(4)),"^"))) Q
I $D(^PS(55,PSODFN,0)),$P($G(^PS(55,PSODFN,0)),U,6)'=2 D EN^PSOHLUP(PSODFN)
F PSORXJ=0:0 S PSORXJ=$O(^PS(55,PSODFN,"P",PSORXJ)) Q:'PSORXJ I $D(^(PSORXJ,0)) S PSORX=^(0) D
.I $D(^PSRX(PSORX,0)) S PSO0=^(0),PSO2=$G(^(2)),STA=+^("STA") I STA<11,PSO2,$P(PSO2,"^",6)'<DT,$E(PSO2,1,7)'>PSOD2!(STA=16) D
..;332 - Set LAST FILL DATE holder field with the fill date upon cancelling
..S $P(^PSRX(PSORX,3),"^",10)=$P(^PSRX(PSORX,3),"^"),$P(^PSRX(PSORX,3),"^",5)=DT,$P(^("STA"),"^")=12,$P(^(7),"^")=1
..D CHKCMOP^PSOUTL(PSORX,"A")
..D REVERSE^PSOBPSU1(PSORX,,"DC",7)
..D CAN^PSOTPCAN(PSORX)
..D FIL^PSOCAN3
..;remove from hold
..I $G(^PSRX(PSORX,"H"))]"" D
...K:$P(^PSRX(PSORX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSORX,"H"),"^"),PSORX) S ^PSRX(PSORX,"H")=""
...I '$P($G(^PSRX(PSORX,2)),"^",2),$P($G(^(3)),"^") S $P(^PSRX(PSORX,2),"^",2)=$P(^(3),"^")
..;remove from park *441
..I $G(^PSRX(PSORX,"PARK")) K ^PSRX(PSORX,"PARK"),^PSRX("APARK",1,PSORX)
..;Add activity record
..S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(PSORX,"A",SUB)) Q:'SUB S ACNT=SUB
..S RFCNT=0 F RF=0:0 S RF=$O(^PSRX(PSORX,1,RF)) Q:'RF S RFCNT=RF S:RF>5 RFCNT=RF+1
..D NOW^%DTC S ACNT=ACNT+1,^PSRX(PSORX,"A",0)="^52.3DA^"_ACNT_"^"_ACNT S ^PSRX(PSORX,"A",ACNT,0)=%_"^"_"C"_"^^"_RFCNT_"^"_"Auto Discontinued on Admission"
..;delete from suspense
..D:$O(^PS(52.5,"B",PSORX,0))
...I $O(^PSRX(PSORX,1,0)) S DA=PSORX,SUSD=$P($G(^PS(52.5,$O(^PS(52.5,"B",PSORX,0)),0)),"^",2) D:'$G(^PS(52.5,$O(^PS(52.5,"B",PSORX,0)),"P")) REF^PSOCAN2
...S DA=$O(^PS(52.5,"B",PSORX,0)),DIK="^PS(52.5," D ^DIK K DIK
..;remove from non-verified file
..I $G(^PS(52.4,PSORX,0))]"" S DIK="^PS(52.4,",DA=PSORX D ^DIK K DIK
..S STAT="OD",PHARMST="",COM="Auto Discontinued on Admission" D EN^PSOHLSN1(PSORX,STAT,PHARMST,COM,"A")
;auto-dc pending orders
;F PSOIORD=0:0 S PSOIORD=$O(^PS(52.41,"AOR",PSODFN,PSOIORD)) Q:'PSOIORD F PSORD=0:0 S PSORD=$O(^PS(52.41,"AOR",PSODFN,PSOIORD,PSORD)) Q:'PSORD D
;.I $P(^PS(52.41,PSORD,0),"^",3)="RF" S DA=PSORD,DIK="^PS(52.41," D ^DIK K DA,DIK Q
;.K ^PS(52.41,"AOR",PSODFN,PSOIORD,PSORD) S $P(^PS(52.41,PSORD,0),"^",3)="DC"
;.D EN^PSOHLSN(+^PS(52.41,PSORD,0),"OC","Auto Canceled on Admission","A")
K PSORD,PSOIORD
Q
KILL K %,%H,%T,ACNT,DA,DFN,DIRUT,DTOUT,PSO,PSO0,PSO2,PSOD,PSOD0,PSOD2,PSODFN,PSODL,PSORX,PSORXJ,PSOSD,RF,RFCNT,SUB,TM,TSKDT,VAIN,X,X1,X2,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
K ORD,PHARMST,STAT,COM S:$D(ZTQUEUED) ZTREQ="@"
Q
SETUP ;initialize nightly Rx cost compile job
K %DT,DIC,DTOUT S DIC(0)="XZM",DIC="^DIC(19.2,",X="PSO COSTDAY NIGHTJOB" D ^DIC
I +Y>0 D EDIT^XUTMOPT("PSO COSTDAY NIGHTJOB") G OUT
D RESCH^XUTMOPT("PSO COSTDAY NIGHTJOB","","","24H","L"),EDIT^XUTMOPT("PSO COSTDAY NIGHTJOB")
OUT K Y,DIC,X,PSOTM,PSOOPTN,PSOPTN,%DT,DTOUT
Q
;initialize management data compile job
SETUP1 K %DT,DIC,DTOUT S DIC(0)="ZXM",DIC="^DIC(19.2,",X="PSO MGMT NIGHTLY COMPILE" D ^DIC
I +Y>0 D EDIT^XUTMOPT("PSO MGMT NIGHTLY COMPILE") G OUT
D RESCH^XUTMOPT("PSO MGMT NIGHTLY COMPILE","","","24H","L"),EDIT^XUTMOPT("PSO MGMT NIGHTLY COMPILE")
K Y,DIC,X,PSOTM,DIR,PSOOPTN,PSOPTN,%DT,DTOUT
Q
APSOD(PSODFN) ;sends mail message that date of death has been deleted
I $G(PSODFN),$D(^PS(52.91,PSODFN,0)) D
.I $P(^PS(52.91,PSODFN,0),"^",3),$P(^(0),"^",4)=5 D
..S $P(^PS(52.91,PSODFN,0),"^",3)="",$P(^PS(52.91,PSODFN,0),"^",4)=""
..S ^PS(52.91,"AX",DT,PSODFN)=""
..I $D(^PS(55,PSODFN,0)),$P($G(^PS(55,PSODFN,"PS")),"^")="" D
...N PSORESPS,PSORESFG,PSORESF1 S PSORESFG=0 F PSORESPS=0:0 S PSORESPS=$O(^PS(53,PSORESPS)) Q:'PSORESPS!(PSORESFG) D
....S PSORESF1=$P($G(^PS(53,PSORESPS,0)),"^") S PSORESF1=$$UP^XLFSTR(PSORESF1) I PSORESF1="NON-VA" S $P(^PS(55,PSODFN,"PS"),"^")=PSORESPS,PSORESFG=1
N DI,DA,DR,DIE,DIC,X,Y
S ZTDTH=$H,ZTREQ="@",ZTSAVE("ZTREQ")="",ZTSAVE("PSODFN")="",ZTRTN="MAIL^PSOAUTOC",ZTDESC="Sends Mail Message that a Date of Death was Deleted",ZTIO="" D ^%ZTLOAD
Q
MAIL ;builds mail message
S DIC=2,DA=PSODFN,DR=.351,DIQ="PTDOD" D EN^DIQ1 I PTDOD(2,DA,.351)]"" G EX1
K ^TMP("PSOHLD",$J),^TMP("PSOAD",$J),TOTRX,TOTPRX
F I=0:0 S I=$O(^PSRX("APSOD",PSODFN,I)) Q:'I S TOTRX=$G(TOTRX)+1
F I=0:0 S I=$O(^PS(52.41,"APSOD",PSODFN,I)) Q:'I S TOTPRX=$G(TOTPRX)+1
F I=0:0 S I=$O(^PS(55,PSODFN,"NVA","APSOD",I)) Q:'I S TOTNVA=$G(TOTNVA)+1
K I Q:'$G(TOTRX)&('$G(TOTPRX))&('$G(TOTNVA))
S ENT=0,DFN=PSODFN D DEM^VADPT
S ENT=ENT+1,^TMP("PSOAD",$J,ENT)=$P(^DPT(PSODFN,0),"^")_" ID#: "_VA("PID")_" DOB: "_$P(VADM(3),"^",2)
S ENT=ENT+1,^TMP("PSOAD",$J,ENT)=" " S Y=DT D DD^%DT
S ENT=ENT+1,^TMP("PSOAD",$J,ENT)="This patient had a Date of Death deleted on "_Y_"."
S ENT=ENT+1,^TMP("PSOAD",$J,ENT)="When a Date of Death is entered ALL active prescriptions, pending orders, and",ENT=ENT+1,^TMP("PSOAD",$J,ENT)="Non-VA Meds are discontinued automatically. The following Outpatient"
S ENT=ENT+1,^TMP("PSOAD",$J,ENT)="Prescriptions and/or Pending Orders should be reviewed for this patient using",ENT=ENT+1,^TMP("PSOAD",$J,ENT)="the Patient Prescription Processing option."
S ENT=ENT+1,^TMP("PSOAD",$J,ENT)=" "
I $G(TOTRX) S ENT=ENT+1,^TMP("PSOAD",$J,ENT)="Total number of Prescriptions found for review is "_TOTRX D
.F I=0:0 S I=$O(^PSRX("APSOD",PSODFN,I)) Q:'I S ^TMP("PSOHLD",$J,$P(^PSDRUG($P(^PSRX(I,0),"^",6),0),"^"),I)=I
.S DRG="" F S DRG=$O(^TMP("PSOHLD",$J,DRG)) Q:DRG="" F I=0:0 S I=$O(^TMP("PSOHLD",$J,DRG,I)) Q:'I S RX=^TMP("PSOHLD",$J,DRG,I) D
..S ENT=ENT+1,^TMP("PSOAD",$J,ENT)="Rx: "_$P(^PSRX(RX,0),"^")_" Drug: "_DRG
N PSOLPI,PSOLPIX,PSOLPIST,PSOLPND
I $G(TOTPRX) S ENT=ENT+1,^TMP("PSOAD",$J,ENT)=" " D
.S ENT=ENT+1,^TMP("PSOAD",$J,ENT)="Total number of Pending Orders found and reinstated is "_TOTPRX
.F PSOLPI=0:0 S PSOLPI=$O(^PS(52.41,"APSOD",PSODFN,PSOLPI)) Q:'PSOLPI D
..S $P(^PS(52.41,PSOLPI,0),"^",3)=$P(^PS(52.41,PSOLPI,"DDSTA"),";"),^PS(52.41,"AOR",PSODFN,$P(^PS(52.41,PSOLPI,"DDSTA"),";",2),PSOLPI)=""
..S PSOLPIX=$P($G(^PS(52.41,PSOLPI,0)),"^"),PSOLPIST=$P($G(^(0)),"^",3)
..I PSOLPIX D
...I PSOLPIST'="NW",PSOLPIST'="RNW",PSOLPIST'="RF" Q
...;Reset remaining cross references
...S PSOLPND=$G(^PS(52.41,PSOLPI,0))
...I $P(PSOLPND,"^",12),$P(PSOLPND,"^",13) S ^PS(52.41,"ACL",$P(PSOLPND,"^",13),$P(PSOLPND,"^",12),PSOLPI)=""
...I $P(^PS(52.41,PSOLPI,"INI"),"^"),$P(PSOLPND,"^",12) S ^PS(52.41,"AD",$P(PSOLPND,"^",12),$P(^PS(52.41,PSOLPI,"INI"),"^"),PSOLPI)=""
...I PSOLPIST="RNW",$P(PSOLPND,"^",21) S ^PS(52.41,"AQ",$P(PSOLPND,"^",21),PSOLPI)=""
...I PSOLPIST="RF" Q
...;Update CPRS with Pending order information on new and renewals
...D EN^PSOHLSN(PSOLPIX,"SC","IP")
..K ^PS(52.41,"APSOD",PSODFN,PSOLPI),ORTYP
..S ENT=ENT+1,ORTYP=$P(^PS(52.41,PSOLPI,0),"^",3)
..S MED=$S($P(^PS(52.41,PSOLPI,0),"^",9):$P(^PSDRUG($P(^PS(52.41,PSOLPI,0),"^",9),0),"^"),1:$P(^PS(50.7,$P(^PS(52.41,PSOLPI,0),"^",8),0),"^"))
..I $G(MED)']"" S MED="NO DRUG OR ORDERABLE ITEM FOUND"
..S ^TMP("PSOAD",$J,ENT)=$S(ORTYP="RF":"Refill",ORTYP="RNW":"Renew",ORTYP="HD":"On Hold",1:"New")_" Order Request - "
..S ^TMP("PSOAD",$J,ENT)=^TMP("PSOAD",$J,ENT)_"Medication: "_MED
I $G(TOTNVA) S ENT=ENT+1,^TMP("PSOAD",$J,ENT)=" " D
.N PSODD,MED,PSOOI,PSONVA,NVA S ENT=ENT+1,^TMP("PSOAD",$J,ENT)="Total number of Non-VA Med Orders found and reinstated is "_TOTNVA
.F NVA=0:0 S NVA=$O(^PS(55,PSODFN,"NVA","APSOD",NVA)) Q:'NVA D
..S PSOOI=$P(^PS(55,PSODFN,"NVA",NVA,0),"^"),PSODD=$P(^(0),"^",2),PLACER=$P(^(0),"^",8),LOCATION=$P(^(0),"^",12),DFN=PSODFN
..S MED=$S(PSODD:$P($G(^PSDRUG(PSODD,0)),"^"),1:$P(^PS(50.7,+PSOOI,0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,+PSOOI,0),"^",2),0),"^"))
..S $P(^PS(55,PSODFN,"NVA",NVA,0),"^",6)="",$P(^(0),"^",7)="" K ^PS(55,PSODFN,"NVA","APSOD",NVA)
..S ENT=ENT+1,^TMP("PSOAD",$J,ENT)="Non-VA "_MED,REIN=1,PSONVA=NVA D REIN^PSONVNEW
..K PSOOI,PSODD,PLACER,LOCATION,MED,REIN
S XMDUZ=.5,XMSUB="Date of Death Deleted for Patient",XMTEXT="^TMP(""PSOAD"",$J," N DIFROM ;*332
;if no members in group, then send to PSORPH key holders ;*332
N PSOMEM
S PSOMEM=$$GOTLOCAL^XMXAPIG("PSO DEATH GROUP") ;CHECK FOR ACTIVE MEMBERS OF MAIL GROUP
I PSOMEM S XMY("G.PSO DEATH GROUP")=""
I 'PSOMEM D
.N PSOI
.F PSOI=0:0 S PSOI=$O(^XUSEC("PSORPH",PSOI)) Q:'PSOI S XMY(PSOI)="" ;*332
D ^XMD
EX1 K ^TMP("PSOHLD",$J),XMSUB,XMTEXT,XMY,XMDUZ,^TMP("PSOAD",$J),I,TOTRX,TOTPRX,PSODFN,ENT,ORTYP,X,Y,MED,RX,PTDOD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOAUTOC 9926 printed Dec 13, 2024@02:24:37 Page 2
PSOAUTOC ;BIR/SAB - auto cancel rxs on admission ;Jan 10, 2022@11:14:59
+1 ;;7.0;OUTPATIENT PHARMACY;**3,24,30,36,88,146,132,223,148,249,324,251,332,441**;DEC 1997;Build 208
+2 ;External reference to File #59.7 supported by DBIA 694
+3 ;External reference to File #55 supported by DBIA 2228
+4 ;External reference ^DPT(PSODFN,.1) supported by DBIA 10035
+5 ;External reference ^DGPM("AMV1" supported by DBIA 2249
+6 ;External reference ^DGPM("APTT1" supported by DBIA 2249
+7 ;External reference ^PSDRUG( supported by DBIA 221
+8 ;External reference ^PS(50.7 supported by DBIA 2223
+9 ;External reference ^XUSEC( supported by IA 10076
+10 ;External refernece GOTLOCAL^XMXAPIG supported by IA 3006
AUTO IF '$PIECE(^PS(59.7,1,40.1),"^")
WRITE $CHAR(7),!,"Auto cancel System Parameter must be set to 'YES'",!,"before prescriptions are discontinued."
+1 KILL %DT,DIC
SET DIC(0)="XZM"
SET (DIE,DIC)="^DIC(19.2,"
SET X="PSO AUTOCANCEL"
DO ^DIC
+2 IF +Y>0
DO EDIT^XUTMOPT("PSO AUTOCANCEL")
GOTO EX
+3 DO RESCH^XUTMOPT("PSO AUTOCANCEL","","","24H","L")
DO EDIT^XUTMOPT("PSO AUTOCANCEL")
EX KILL Y,C,D,D0,DI,DQ,DA,DIE,DR,DIC,X
+1 QUIT
TASK ;TaskMan entry point
+1 if '$PIECE(^PS(59.7,1,40.1),"^")
GOTO KILL
SET X="T-3"
DO ^%DT
SET PSOD2=Y
SET PSOD0=Y-.01
SET PSODL=Y+.3
+2 SET PSOD=PSOD0
FOR
SET PSOD=$ORDER(^DGPM("AMV1",PSOD))
SET PSODFN=0
if 'PSOD!(PSOD>PSODL)
QUIT
FOR PSODFN=0:0
SET PSODFN=$ORDER(^DGPM("AMV1",PSOD,PSODFN))
if 'PSODFN
QUIT
IF $GET(^DPT(PSODFN,.1))]""
IF $ORDER(^PS(55,PSODFN,"P",0))
IF '$ORDER(^DGPM("APTT1",PSODFN,PSOD))
DO CAN
+3 GOTO KILL
CAN ;discontinue Rxs
+1 SET DFN=PSODFN
KILL VAIN
DO INP^VADPT
IF $PIECE($GET(VAIN(4)),"^")
IF $DATA(^PS(59.7,1,40.19,"B",$PIECE($GET(VAIN(4)),"^")))
QUIT
+2 IF $DATA(^PS(55,PSODFN,0))
IF $PIECE($GET(^PS(55,PSODFN,0)),U,6)'=2
DO EN^PSOHLUP(PSODFN)
+3 FOR PSORXJ=0:0
SET PSORXJ=$ORDER(^PS(55,PSODFN,"P",PSORXJ))
if 'PSORXJ
QUIT
IF $DATA(^(PSORXJ,0))
SET PSORX=^(0)
Begin DoDot:1
+4 IF $DATA(^PSRX(PSORX,0))
SET PSO0=^(0)
SET PSO2=$GET(^(2))
SET STA=+^("STA")
IF STA<11
IF PSO2
IF $PIECE(PSO2,"^",6)'<DT
IF $EXTRACT(PSO2,1,7)'>PSOD2!(STA=16)
Begin DoDot:2
+5 ;332 - Set LAST FILL DATE holder field with the fill date upon cancelling
+6 SET $PIECE(^PSRX(PSORX,3),"^",10)=$PIECE(^PSRX(PSORX,3),"^")
SET $PIECE(^PSRX(PSORX,3),"^",5)=DT
SET $PIECE(^("STA"),"^")=12
SET $PIECE(^(7),"^")=1
+7 DO CHKCMOP^PSOUTL(PSORX,"A")
+8 DO REVERSE^PSOBPSU1(PSORX,,"DC",7)
+9 DO CAN^PSOTPCAN(PSORX)
+10 DO FIL^PSOCAN3
+11 ;remove from hold
+12 IF $GET(^PSRX(PSORX,"H"))]""
Begin DoDot:3
+13 if $PIECE(^PSRX(PSORX,"H"),"^")
KILL ^PSRX("AH",$PIECE(^PSRX(PSORX,"H"),"^"),PSORX)
SET ^PSRX(PSORX,"H")=""
+14 IF '$PIECE($GET(^PSRX(PSORX,2)),"^",2)
IF $PIECE($GET(^(3)),"^")
SET $PIECE(^PSRX(PSORX,2),"^",2)=$PIECE(^(3),"^")
End DoDot:3
+15 ;remove from park *441
+16 IF $GET(^PSRX(PSORX,"PARK"))
KILL ^PSRX(PSORX,"PARK"),^PSRX("APARK",1,PSORX)
+17 ;Add activity record
+18 SET ACNT=0
FOR SUB=0:0
SET SUB=$ORDER(^PSRX(PSORX,"A",SUB))
if 'SUB
QUIT
SET ACNT=SUB
+19 SET RFCNT=0
FOR RF=0:0
SET RF=$ORDER(^PSRX(PSORX,1,RF))
if 'RF
QUIT
SET RFCNT=RF
if RF>5
SET RFCNT=RF+1
+20 DO NOW^%DTC
SET ACNT=ACNT+1
SET ^PSRX(PSORX,"A",0)="^52.3DA^"_ACNT_"^"_ACNT
SET ^PSRX(PSORX,"A",ACNT,0)=%_"^"_"C"_"^^"_RFCNT_"^"_"Auto Discontinued on Admission"
+21 ;delete from suspense
+22 if $ORDER(^PS(52.5,"B",PSORX,0))
Begin DoDot:3
+23 IF $ORDER(^PSRX(PSORX,1,0))
SET DA=PSORX
SET SUSD=$PIECE($GET(^PS(52.5,$ORDER(^PS(52.5,"B",PSORX,0)),0)),"^",2)
if '$GET(^PS(52.5,$ORDER(^PS(52.5,"B",PSORX,0)),"P"))
DO REF^PSOCAN2
+24 SET DA=$ORDER(^PS(52.5,"B",PSORX,0))
SET DIK="^PS(52.5,"
DO ^DIK
KILL DIK
End DoDot:3
+25 ;remove from non-verified file
+26 IF $GET(^PS(52.4,PSORX,0))]""
SET DIK="^PS(52.4,"
SET DA=PSORX
DO ^DIK
KILL DIK
+27 SET STAT="OD"
SET PHARMST=""
SET COM="Auto Discontinued on Admission"
DO EN^PSOHLSN1(PSORX,STAT,PHARMST,COM,"A")
End DoDot:2
End DoDot:1
+28 ;auto-dc pending orders
+29 ;F PSOIORD=0:0 S PSOIORD=$O(^PS(52.41,"AOR",PSODFN,PSOIORD)) Q:'PSOIORD F PSORD=0:0 S PSORD=$O(^PS(52.41,"AOR",PSODFN,PSOIORD,PSORD)) Q:'PSORD D
+30 ;.I $P(^PS(52.41,PSORD,0),"^",3)="RF" S DA=PSORD,DIK="^PS(52.41," D ^DIK K DA,DIK Q
+31 ;.K ^PS(52.41,"AOR",PSODFN,PSOIORD,PSORD) S $P(^PS(52.41,PSORD,0),"^",3)="DC"
+32 ;.D EN^PSOHLSN(+^PS(52.41,PSORD,0),"OC","Auto Canceled on Admission","A")
+33 KILL PSORD,PSOIORD
+34 QUIT
KILL KILL %,%H,%T,ACNT,DA,DFN,DIRUT,DTOUT,PSO,PSO0,PSO2,PSOD,PSOD0,PSOD2,PSODFN,PSODL,PSORX,PSORXJ,PSOSD,RF,RFCNT,SUB,TM,TSKDT,VAIN,X,X1,X2,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+1 KILL ORD,PHARMST,STAT,COM
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 QUIT
SETUP ;initialize nightly Rx cost compile job
+1 KILL %DT,DIC,DTOUT
SET DIC(0)="XZM"
SET DIC="^DIC(19.2,"
SET X="PSO COSTDAY NIGHTJOB"
DO ^DIC
+2 IF +Y>0
DO EDIT^XUTMOPT("PSO COSTDAY NIGHTJOB")
GOTO OUT
+3 DO RESCH^XUTMOPT("PSO COSTDAY NIGHTJOB","","","24H","L")
DO EDIT^XUTMOPT("PSO COSTDAY NIGHTJOB")
OUT KILL Y,DIC,X,PSOTM,PSOOPTN,PSOPTN,%DT,DTOUT
+1 QUIT
+2 ;initialize management data compile job
SETUP1 KILL %DT,DIC,DTOUT
SET DIC(0)="ZXM"
SET DIC="^DIC(19.2,"
SET X="PSO MGMT NIGHTLY COMPILE"
DO ^DIC
+1 IF +Y>0
DO EDIT^XUTMOPT("PSO MGMT NIGHTLY COMPILE")
GOTO OUT
+2 DO RESCH^XUTMOPT("PSO MGMT NIGHTLY COMPILE","","","24H","L")
DO EDIT^XUTMOPT("PSO MGMT NIGHTLY COMPILE")
+3 KILL Y,DIC,X,PSOTM,DIR,PSOOPTN,PSOPTN,%DT,DTOUT
+4 QUIT
APSOD(PSODFN) ;sends mail message that date of death has been deleted
+1 IF $GET(PSODFN)
IF $DATA(^PS(52.91,PSODFN,0))
Begin DoDot:1
+2 IF $PIECE(^PS(52.91,PSODFN,0),"^",3)
IF $PIECE(^(0),"^",4)=5
Begin DoDot:2
+3 SET $PIECE(^PS(52.91,PSODFN,0),"^",3)=""
SET $PIECE(^PS(52.91,PSODFN,0),"^",4)=""
+4 SET ^PS(52.91,"AX",DT,PSODFN)=""
+5 IF $DATA(^PS(55,PSODFN,0))
IF $PIECE($GET(^PS(55,PSODFN,"PS")),"^")=""
Begin DoDot:3
+6 NEW PSORESPS,PSORESFG,PSORESF1
SET PSORESFG=0
FOR PSORESPS=0:0
SET PSORESPS=$ORDER(^PS(53,PSORESPS))
if 'PSORESPS!(PSORESFG)
QUIT
Begin DoDot:4
+7 SET PSORESF1=$PIECE($GET(^PS(53,PSORESPS,0)),"^")
SET PSORESF1=$$UP^XLFSTR(PSORESF1)
IF PSORESF1="NON-VA"
SET $PIECE(^PS(55,PSODFN,"PS"),"^")=PSORESPS
SET PSORESFG=1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+8 NEW DI,DA,DR,DIE,DIC,X,Y
+9 SET ZTDTH=$HOROLOG
SET ZTREQ="@"
SET ZTSAVE("ZTREQ")=""
SET ZTSAVE("PSODFN")=""
SET ZTRTN="MAIL^PSOAUTOC"
SET ZTDESC="Sends Mail Message that a Date of Death was Deleted"
SET ZTIO=""
DO ^%ZTLOAD
+10 QUIT
MAIL ;builds mail message
+1 SET DIC=2
SET DA=PSODFN
SET DR=.351
SET DIQ="PTDOD"
DO EN^DIQ1
IF PTDOD(2,DA,.351)]""
GOTO EX1
+2 KILL ^TMP("PSOHLD",$JOB),^TMP("PSOAD",$JOB),TOTRX,TOTPRX
+3 FOR I=0:0
SET I=$ORDER(^PSRX("APSOD",PSODFN,I))
if 'I
QUIT
SET TOTRX=$GET(TOTRX)+1
+4 FOR I=0:0
SET I=$ORDER(^PS(52.41,"APSOD",PSODFN,I))
if 'I
QUIT
SET TOTPRX=$GET(TOTPRX)+1
+5 FOR I=0:0
SET I=$ORDER(^PS(55,PSODFN,"NVA","APSOD",I))
if 'I
QUIT
SET TOTNVA=$GET(TOTNVA)+1
+6 KILL I
if '$GET(TOTRX)&('$GET(TOTPRX))&('$GET(TOTNVA))
QUIT
+7 SET ENT=0
SET DFN=PSODFN
DO DEM^VADPT
+8 SET ENT=ENT+1
SET ^TMP("PSOAD",$JOB,ENT)=$PIECE(^DPT(PSODFN,0),"^")_" ID#: "_VA("PID")_" DOB: "_$PIECE(VADM(3),"^",2)
+9 SET ENT=ENT+1
SET ^TMP("PSOAD",$JOB,ENT)=" "
SET Y=DT
DO DD^%DT
+10 SET ENT=ENT+1
SET ^TMP("PSOAD",$JOB,ENT)="This patient had a Date of Death deleted on "_Y_"."
+11 SET ENT=ENT+1
SET ^TMP("PSOAD",$JOB,ENT)="When a Date of Death is entered ALL active prescriptions, pending orders, and"
SET ENT=ENT+1
SET ^TMP("PSOAD",$JOB,ENT)="Non-VA Meds are discontinued automatically. The following Outpatient"
+12 SET ENT=ENT+1
SET ^TMP("PSOAD",$JOB,ENT)="Prescriptions and/or Pending Orders should be reviewed for this patient using"
SET ENT=ENT+1
SET ^TMP("PSOAD",$JOB,ENT)="the Patient Prescription Processing option."
+13 SET ENT=ENT+1
SET ^TMP("PSOAD",$JOB,ENT)=" "
+14 IF $GET(TOTRX)
SET ENT=ENT+1
SET ^TMP("PSOAD",$JOB,ENT)="Total number of Prescriptions found for review is "_TOTRX
Begin DoDot:1
+15 FOR I=0:0
SET I=$ORDER(^PSRX("APSOD",PSODFN,I))
if 'I
QUIT
SET ^TMP("PSOHLD",$JOB,$PIECE(^PSDRUG($PIECE(^PSRX(I,0),"^",6),0),"^"),I)=I
+16 SET DRG=""
FOR
SET DRG=$ORDER(^TMP("PSOHLD",$JOB,DRG))
if DRG=""
QUIT
FOR I=0:0
SET I=$ORDER(^TMP("PSOHLD",$JOB,DRG,I))
if 'I
QUIT
SET RX=^TMP("PSOHLD",$JOB,DRG,I)
Begin DoDot:2
+17 SET ENT=ENT+1
SET ^TMP("PSOAD",$JOB,ENT)="Rx: "_$PIECE(^PSRX(RX,0),"^")_" Drug: "_DRG
End DoDot:2
End DoDot:1
+18 NEW PSOLPI,PSOLPIX,PSOLPIST,PSOLPND
+19 IF $GET(TOTPRX)
SET ENT=ENT+1
SET ^TMP("PSOAD",$JOB,ENT)=" "
Begin DoDot:1
+20 SET ENT=ENT+1
SET ^TMP("PSOAD",$JOB,ENT)="Total number of Pending Orders found and reinstated is "_TOTPRX
+21 FOR PSOLPI=0:0
SET PSOLPI=$ORDER(^PS(52.41,"APSOD",PSODFN,PSOLPI))
if 'PSOLPI
QUIT
Begin DoDot:2
+22 SET $PIECE(^PS(52.41,PSOLPI,0),"^",3)=$PIECE(^PS(52.41,PSOLPI,"DDSTA"),";")
SET ^PS(52.41,"AOR",PSODFN,$PIECE(^PS(52.41,PSOLPI,"DDSTA"),";",2),PSOLPI)=""
+23 SET PSOLPIX=$PIECE($GET(^PS(52.41,PSOLPI,0)),"^")
SET PSOLPIST=$PIECE($GET(^(0)),"^",3)
+24 IF PSOLPIX
Begin DoDot:3
+25 IF PSOLPIST'="NW"
IF PSOLPIST'="RNW"
IF PSOLPIST'="RF"
QUIT
+26 ;Reset remaining cross references
+27 SET PSOLPND=$GET(^PS(52.41,PSOLPI,0))
+28 IF $PIECE(PSOLPND,"^",12)
IF $PIECE(PSOLPND,"^",13)
SET ^PS(52.41,"ACL",$PIECE(PSOLPND,"^",13),$PIECE(PSOLPND,"^",12),PSOLPI)=""
+29 IF $PIECE(^PS(52.41,PSOLPI,"INI"),"^")
IF $PIECE(PSOLPND,"^",12)
SET ^PS(52.41,"AD",$PIECE(PSOLPND,"^",12),$PIECE(^PS(52.41,PSOLPI,"INI"),"^"),PSOLPI)=""
+30 IF PSOLPIST="RNW"
IF $PIECE(PSOLPND,"^",21)
SET ^PS(52.41,"AQ",$PIECE(PSOLPND,"^",21),PSOLPI)=""
+31 IF PSOLPIST="RF"
QUIT
+32 ;Update CPRS with Pending order information on new and renewals
+33 DO EN^PSOHLSN(PSOLPIX,"SC","IP")
End DoDot:3
+34 KILL ^PS(52.41,"APSOD",PSODFN,PSOLPI),ORTYP
+35 SET ENT=ENT+1
SET ORTYP=$PIECE(^PS(52.41,PSOLPI,0),"^",3)
+36 SET MED=$SELECT($PIECE(^PS(52.41,PSOLPI,0),"^",9):$PIECE(^PSDRUG($PIECE(^PS(52.41,PSOLPI,0),"^",9),0),"^"),1:$PIECE(^PS(50.7,$PIECE(^PS(52.41,PSOLPI,0),"^",8),0),"^"))
+37 IF $GET(MED)']""
SET MED="NO DRUG OR ORDERABLE ITEM FOUND"
+38 SET ^TMP("PSOAD",$JOB,ENT)=$SELECT(ORTYP="RF":"Refill",ORTYP="RNW":"Renew",ORTYP="HD":"On Hold",1:"New")_" Order Request - "
+39 SET ^TMP("PSOAD",$JOB,ENT)=^TMP("PSOAD",$JOB,ENT)_"Medication: "_MED
End DoDot:2
End DoDot:1
+40 IF $GET(TOTNVA)
SET ENT=ENT+1
SET ^TMP("PSOAD",$JOB,ENT)=" "
Begin DoDot:1
+41 NEW PSODD,MED,PSOOI,PSONVA,NVA
SET ENT=ENT+1
SET ^TMP("PSOAD",$JOB,ENT)="Total number of Non-VA Med Orders found and reinstated is "_TOTNVA
+42 FOR NVA=0:0
SET NVA=$ORDER(^PS(55,PSODFN,"NVA","APSOD",NVA))
if 'NVA
QUIT
Begin DoDot:2
+43 SET PSOOI=$PIECE(^PS(55,PSODFN,"NVA",NVA,0),"^")
SET PSODD=$PIECE(^(0),"^",2)
SET PLACER=$PIECE(^(0),"^",8)
SET LOCATION=$PIECE(^(0),"^",12)
SET DFN=PSODFN
+44 SET MED=$SELECT(PSODD:$PIECE($GET(^PSDRUG(PSODD,0)),"^"),1:$PIECE(^PS(50.7,+PSOOI,0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^PS(50.7,+PSOOI,0),"^",2),0),"^"))
+45 SET $PIECE(^PS(55,PSODFN,"NVA",NVA,0),"^",6)=""
SET $PIECE(^(0),"^",7)=""
KILL ^PS(55,PSODFN,"NVA","APSOD",NVA)
+46 SET ENT=ENT+1
SET ^TMP("PSOAD",$JOB,ENT)="Non-VA "_MED
SET REIN=1
SET PSONVA=NVA
DO REIN^PSONVNEW
+47 KILL PSOOI,PSODD,PLACER,LOCATION,MED,REIN
End DoDot:2
End DoDot:1
+48 ;*332
SET XMDUZ=.5
SET XMSUB="Date of Death Deleted for Patient"
SET XMTEXT="^TMP(""PSOAD"",$J,"
NEW DIFROM
+49 ;if no members in group, then send to PSORPH key holders ;*332
+50 NEW PSOMEM
+51 ;CHECK FOR ACTIVE MEMBERS OF MAIL GROUP
SET PSOMEM=$$GOTLOCAL^XMXAPIG("PSO DEATH GROUP")
+52 IF PSOMEM
SET XMY("G.PSO DEATH GROUP")=""
+53 IF 'PSOMEM
Begin DoDot:1
+54 NEW PSOI
+55 ;*332
FOR PSOI=0:0
SET PSOI=$ORDER(^XUSEC("PSORPH",PSOI))
if 'PSOI
QUIT
SET XMY(PSOI)=""
End DoDot:1
+56 DO ^XMD
EX1 KILL ^TMP("PSOHLD",$JOB),XMSUB,XMTEXT,XMY,XMDUZ,^TMP("PSOAD",$JOB),I,TOTRX,TOTPRX,PSODFN,ENT,ORTYP,X,Y,MED,RX,PTDOD
+1 QUIT
