- 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 Jan 18, 2025@03:25:46 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