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

PSOAUTOC.m

Go to the documentation of this file.
  1. 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
  1. ;External reference to File #59.7 supported by DBIA 694
  1. ;External reference to File #55 supported by DBIA 2228
  1. ;External reference ^DPT(PSODFN,.1) supported by DBIA 10035
  1. ;External reference ^DGPM("AMV1" supported by DBIA 2249
  1. ;External reference ^DGPM("APTT1" supported by DBIA 2249
  1. ;External reference ^PSDRUG( supported by DBIA 221
  1. ;External reference ^PS(50.7 supported by DBIA 2223
  1. ;External reference ^XUSEC( supported by IA 10076
  1. ;External refernece GOTLOCAL^XMXAPIG supported by IA 3006
  1. 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."
  1. K %DT,DIC S DIC(0)="XZM",(DIE,DIC)="^DIC(19.2,",X="PSO AUTOCANCEL" D ^DIC
  1. I +Y>0 D EDIT^XUTMOPT("PSO AUTOCANCEL") G EX
  1. D RESCH^XUTMOPT("PSO AUTOCANCEL","","","24H","L"),EDIT^XUTMOPT("PSO AUTOCANCEL")
  1. EX K Y,C,D,D0,DI,DQ,DA,DIE,DR,DIC,X
  1. Q
  1. TASK ;TaskMan entry point
  1. G:'$P(^PS(59.7,1,40.1),"^") KILL S X="T-3" D ^%DT S PSOD2=Y,PSOD0=Y-.01,PSODL=Y+.3
  1. 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
  1. G KILL
  1. CAN ;discontinue Rxs
  1. 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
  1. I $D(^PS(55,PSODFN,0)),$P($G(^PS(55,PSODFN,0)),U,6)'=2 D EN^PSOHLUP(PSODFN)
  1. F PSORXJ=0:0 S PSORXJ=$O(^PS(55,PSODFN,"P",PSORXJ)) Q:'PSORXJ I $D(^(PSORXJ,0)) S PSORX=^(0) D
  1. .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
  1. ..;332 - Set LAST FILL DATE holder field with the fill date upon cancelling
  1. ..S $P(^PSRX(PSORX,3),"^",10)=$P(^PSRX(PSORX,3),"^"),$P(^PSRX(PSORX,3),"^",5)=DT,$P(^("STA"),"^")=12,$P(^(7),"^")=1
  1. ..D CHKCMOP^PSOUTL(PSORX,"A")
  1. ..D REVERSE^PSOBPSU1(PSORX,,"DC",7)
  1. ..D CAN^PSOTPCAN(PSORX)
  1. ..D FIL^PSOCAN3
  1. ..;remove from hold
  1. ..I $G(^PSRX(PSORX,"H"))]"" D
  1. ...K:$P(^PSRX(PSORX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSORX,"H"),"^"),PSORX) S ^PSRX(PSORX,"H")=""
  1. ...I '$P($G(^PSRX(PSORX,2)),"^",2),$P($G(^(3)),"^") S $P(^PSRX(PSORX,2),"^",2)=$P(^(3),"^")
  1. ..;remove from park *441
  1. ..I $G(^PSRX(PSORX,"PARK")) K ^PSRX(PSORX,"PARK"),^PSRX("APARK",1,PSORX)
  1. ..;Add activity record
  1. ..S ACNT=0 F SUB=0:0 S SUB=$O(^PSRX(PSORX,"A",SUB)) Q:'SUB S ACNT=SUB
  1. ..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
  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"
  1. ..;delete from suspense
  1. ..D:$O(^PS(52.5,"B",PSORX,0))
  1. ...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
  1. ...S DA=$O(^PS(52.5,"B",PSORX,0)),DIK="^PS(52.5," D ^DIK K DIK
  1. ..;remove from non-verified file
  1. ..I $G(^PS(52.4,PSORX,0))]"" S DIK="^PS(52.4,",DA=PSORX D ^DIK K DIK
  1. ..S STAT="OD",PHARMST="",COM="Auto Discontinued on Admission" D EN^PSOHLSN1(PSORX,STAT,PHARMST,COM,"A")
  1. ;auto-dc pending orders
  1. ;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
  1. ;.I $P(^PS(52.41,PSORD,0),"^",3)="RF" S DA=PSORD,DIK="^PS(52.41," D ^DIK K DA,DIK Q
  1. ;.K ^PS(52.41,"AOR",PSODFN,PSOIORD,PSORD) S $P(^PS(52.41,PSORD,0),"^",3)="DC"
  1. ;.D EN^PSOHLSN(+^PS(52.41,PSORD,0),"OC","Auto Canceled on Admission","A")
  1. K PSORD,PSOIORD
  1. Q
  1. 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
  1. K ORD,PHARMST,STAT,COM S:$D(ZTQUEUED) ZTREQ="@"
  1. Q
  1. SETUP ;initialize nightly Rx cost compile job
  1. K %DT,DIC,DTOUT S DIC(0)="XZM",DIC="^DIC(19.2,",X="PSO COSTDAY NIGHTJOB" D ^DIC
  1. I +Y>0 D EDIT^XUTMOPT("PSO COSTDAY NIGHTJOB") G OUT
  1. D RESCH^XUTMOPT("PSO COSTDAY NIGHTJOB","","","24H","L"),EDIT^XUTMOPT("PSO COSTDAY NIGHTJOB")
  1. OUT K Y,DIC,X,PSOTM,PSOOPTN,PSOPTN,%DT,DTOUT
  1. Q
  1. ;initialize management data compile job
  1. SETUP1 K %DT,DIC,DTOUT S DIC(0)="ZXM",DIC="^DIC(19.2,",X="PSO MGMT NIGHTLY COMPILE" D ^DIC
  1. I +Y>0 D EDIT^XUTMOPT("PSO MGMT NIGHTLY COMPILE") G OUT
  1. D RESCH^XUTMOPT("PSO MGMT NIGHTLY COMPILE","","","24H","L"),EDIT^XUTMOPT("PSO MGMT NIGHTLY COMPILE")
  1. K Y,DIC,X,PSOTM,DIR,PSOOPTN,PSOPTN,%DT,DTOUT
  1. Q
  1. APSOD(PSODFN) ;sends mail message that date of death has been deleted
  1. I $G(PSODFN),$D(^PS(52.91,PSODFN,0)) D
  1. .I $P(^PS(52.91,PSODFN,0),"^",3),$P(^(0),"^",4)=5 D
  1. ..S $P(^PS(52.91,PSODFN,0),"^",3)="",$P(^PS(52.91,PSODFN,0),"^",4)=""
  1. ..S ^PS(52.91,"AX",DT,PSODFN)=""
  1. ..I $D(^PS(55,PSODFN,0)),$P($G(^PS(55,PSODFN,"PS")),"^")="" D
  1. ...N PSORESPS,PSORESFG,PSORESF1 S PSORESFG=0 F PSORESPS=0:0 S PSORESPS=$O(^PS(53,PSORESPS)) Q:'PSORESPS!(PSORESFG) D
  1. ....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
  1. N DI,DA,DR,DIE,DIC,X,Y
  1. 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
  1. Q
  1. MAIL ;builds mail message
  1. S DIC=2,DA=PSODFN,DR=.351,DIQ="PTDOD" D EN^DIQ1 I PTDOD(2,DA,.351)]"" G EX1
  1. K ^TMP("PSOHLD",$J),^TMP("PSOAD",$J),TOTRX,TOTPRX
  1. F I=0:0 S I=$O(^PSRX("APSOD",PSODFN,I)) Q:'I S TOTRX=$G(TOTRX)+1
  1. F I=0:0 S I=$O(^PS(52.41,"APSOD",PSODFN,I)) Q:'I S TOTPRX=$G(TOTPRX)+1
  1. F I=0:0 S I=$O(^PS(55,PSODFN,"NVA","APSOD",I)) Q:'I S TOTNVA=$G(TOTNVA)+1
  1. K I Q:'$G(TOTRX)&('$G(TOTPRX))&('$G(TOTNVA))
  1. S ENT=0,DFN=PSODFN D DEM^VADPT
  1. S ENT=ENT+1,^TMP("PSOAD",$J,ENT)=$P(^DPT(PSODFN,0),"^")_" ID#: "_VA("PID")_" DOB: "_$P(VADM(3),"^",2)
  1. S ENT=ENT+1,^TMP("PSOAD",$J,ENT)=" " S Y=DT D DD^%DT
  1. S ENT=ENT+1,^TMP("PSOAD",$J,ENT)="This patient had a Date of Death deleted on "_Y_"."
  1. 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"
  1. 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."
  1. S ENT=ENT+1,^TMP("PSOAD",$J,ENT)=" "
  1. I $G(TOTRX) S ENT=ENT+1,^TMP("PSOAD",$J,ENT)="Total number of Prescriptions found for review is "_TOTRX D
  1. .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
  1. .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
  1. ..S ENT=ENT+1,^TMP("PSOAD",$J,ENT)="Rx: "_$P(^PSRX(RX,0),"^")_" Drug: "_DRG
  1. N PSOLPI,PSOLPIX,PSOLPIST,PSOLPND
  1. I $G(TOTPRX) S ENT=ENT+1,^TMP("PSOAD",$J,ENT)=" " D
  1. .S ENT=ENT+1,^TMP("PSOAD",$J,ENT)="Total number of Pending Orders found and reinstated is "_TOTPRX
  1. .F PSOLPI=0:0 S PSOLPI=$O(^PS(52.41,"APSOD",PSODFN,PSOLPI)) Q:'PSOLPI D
  1. ..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)=""
  1. ..S PSOLPIX=$P($G(^PS(52.41,PSOLPI,0)),"^"),PSOLPIST=$P($G(^(0)),"^",3)
  1. ..I PSOLPIX D
  1. ...I PSOLPIST'="NW",PSOLPIST'="RNW",PSOLPIST'="RF" Q
  1. ...;Reset remaining cross references
  1. ...S PSOLPND=$G(^PS(52.41,PSOLPI,0))
  1. ...I $P(PSOLPND,"^",12),$P(PSOLPND,"^",13) S ^PS(52.41,"ACL",$P(PSOLPND,"^",13),$P(PSOLPND,"^",12),PSOLPI)=""
  1. ...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)=""
  1. ...I PSOLPIST="RNW",$P(PSOLPND,"^",21) S ^PS(52.41,"AQ",$P(PSOLPND,"^",21),PSOLPI)=""
  1. ...I PSOLPIST="RF" Q
  1. ...;Update CPRS with Pending order information on new and renewals
  1. ...D EN^PSOHLSN(PSOLPIX,"SC","IP")
  1. ..K ^PS(52.41,"APSOD",PSODFN,PSOLPI),ORTYP
  1. ..S ENT=ENT+1,ORTYP=$P(^PS(52.41,PSOLPI,0),"^",3)
  1. ..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),"^"))
  1. ..I $G(MED)']"" S MED="NO DRUG OR ORDERABLE ITEM FOUND"
  1. ..S ^TMP("PSOAD",$J,ENT)=$S(ORTYP="RF":"Refill",ORTYP="RNW":"Renew",ORTYP="HD":"On Hold",1:"New")_" Order Request - "
  1. ..S ^TMP("PSOAD",$J,ENT)=^TMP("PSOAD",$J,ENT)_"Medication: "_MED
  1. I $G(TOTNVA) S ENT=ENT+1,^TMP("PSOAD",$J,ENT)=" " D
  1. .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
  1. .F NVA=0:0 S NVA=$O(^PS(55,PSODFN,"NVA","APSOD",NVA)) Q:'NVA D
  1. ..S PSOOI=$P(^PS(55,PSODFN,"NVA",NVA,0),"^"),PSODD=$P(^(0),"^",2),PLACER=$P(^(0),"^",8),LOCATION=$P(^(0),"^",12),DFN=PSODFN
  1. ..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),"^"))
  1. ..S $P(^PS(55,PSODFN,"NVA",NVA,0),"^",6)="",$P(^(0),"^",7)="" K ^PS(55,PSODFN,"NVA","APSOD",NVA)
  1. ..S ENT=ENT+1,^TMP("PSOAD",$J,ENT)="Non-VA "_MED,REIN=1,PSONVA=NVA D REIN^PSONVNEW
  1. ..K PSOOI,PSODD,PLACER,LOCATION,MED,REIN
  1. S XMDUZ=.5,XMSUB="Date of Death Deleted for Patient",XMTEXT="^TMP(""PSOAD"",$J," N DIFROM ;*332
  1. ;if no members in group, then send to PSORPH key holders ;*332
  1. N PSOMEM
  1. S PSOMEM=$$GOTLOCAL^XMXAPIG("PSO DEATH GROUP") ;CHECK FOR ACTIVE MEMBERS OF MAIL GROUP
  1. I PSOMEM S XMY("G.PSO DEATH GROUP")=""
  1. I 'PSOMEM D
  1. .N PSOI
  1. .F PSOI=0:0 S PSOI=$O(^XUSEC("PSORPH",PSOI)) Q:'PSOI S XMY(PSOI)="" ;*332
  1. D ^XMD
  1. EX1 K ^TMP("PSOHLD",$J),XMSUB,XMTEXT,XMY,XMDUZ,^TMP("PSOAD",$J),I,TOTRX,TOTPRX,PSODFN,ENT,ORTYP,X,Y,MED,RX,PTDOD
  1. Q