PSJADT0 ;BIR/CML3,PR,MLM-AUTO DC/HOLD CANCEL ;11 Aug 98 / 8:25 AM
;;5.0;INPATIENT MEDICATIONS ;**17,111,112,135,181,274,390**;16 DEC 97;Build 7
;
;Reference to ^PS(55 supported by DBIA #2191.
;
ENDC ; dc active orders first, then non-verified orders
W:'$D(PSJQUIET)&'$D(DGQUIET) !,"...discontinuing Inpatient Medication orders..."
S $P(PSJPIND,"^")=""
D NOW^%DTC N PSJDCDT S (PSJDCDT,PSGDT)=+%,PSJSYSW0="" I PSJFW S PSJSYSW=$O(^PS(59.6,"B",PSJFW,0)) S:PSJSYSW PSJSYSW0=$G(^PS(59.6,PSJSYSW,0))
I PSGALO=1010!(PSGALO=1030)!(PSGALO=1050) D AUDDD
D ENUNM^PSGOU S PSGALR=10,DIE="^PS(55,"_PSGP_",5," S:PSJFW PSGTOL=1,PSGUOW=PSJFW,PSGTOO=1
F PSJS=PSGDT:0 S PSJS=$O(^PS(55,PSGP,5,"AUS",PSJS)) Q:'PSJS F PSJDA=0:0 S PSJDA=$O(^PS(55,PSGP,5,"AUS",PSJS,PSJDA)) Q:'PSJDA D
.Q:'$$DCIMO(PSGP,PSJDA,"U")
.;first naked reference below refers to the full global reference to the right of the = sign (inside the $S)
.K DA S DA(1)=PSGP,DA=PSJDA,PSGAL("C")=0,$P(^(2),"^",3)=$S($D(^PS(55,PSGP,5,DA,2)):$P(^(2),"^",4),1:"")
.D ^PSGAL5
.K TMP
.S TMP(55.06,""_PSJDA_","_PSGP_","_"",28)="D"
.S TMP(55.06,""_PSJDA_","_PSGP_","_"",136)=$S(PSGALO=1010:"DD",1:"DA")
.D FILE^DIE("","TMP")
.K TMP
.S TMP(55.06,""_PSJDA_","_PSGP_","_"",34)=PSJDCDT
.S TMP(55.06,""_PSJDA_","_PSGP_","_"",49)=1
.D FILE^DIE("","TMP")
.K TMP
.D EN1^PSJHL2(PSGP,"OD",PSJDA_"U","AUTO DC")
.I PSGALO'=1050 S DA=PSJDA,^PS(55,"AUE",PSGP,DA)="" I $P(PSJSYSW0,"^",15),(PSGALO'<1060) S $P(^PS(55,PSGP,5,PSJDA,7),"^",1,2)=PSJDCDT_"^D" D ENL^PSGVDS
S PSGTOO=2 F PSJDA=0:0 S PSJDA=$O(^PS(53.1,"AC",PSGP,PSJDA)) Q:'PSJDA D
.Q:'$$DCIMO(PSGP,PSJDA,"P")
.I PSGALO'<1060,$P(PSJSYSW0,U,15),$P($G(^PS(53.1,PSJDA,0)),U,9)="N" K DA D ENLBL^PSIVOPT(PSGTOL,PSGUOW,DFN,2,+PSJDA,"AD")
.K DA S DA=PSJDA D I $P($G(^PS(53.1,DA,0)),"^",21) D EN1^PSJHL2(PSGP,"OC",PSJDA_"P","AUTO DC")
..K TMP
..S TMP(53.1,""_PSJDA_","_"",28)="D"
..S TMP(53.1,""_PSJDA_","_"",42)=1
..D FILE^DIE("","TMP")
..K TMP
;
ENIV ;
S DFN=PSGP F PSJIVON=0:0 S PSJIVON=$O(^PS(55,DFN,"IV",PSJIVON)) Q:'PSJIVON S Y=$G(^(PSJIVON,0)) I "PDEN"'[$P(Y,U,17) S P(17)=$P(Y,U,17),P(3)=$P(Y,U,3) D DC
Q
DC ;
Q:'$$DCIMO(DFN,PSJIVON,"V")
S (ON,ON55)=PSJIVON_"V" D NOW^%DTC I P(17)="H",P(3)<% D D EXPIR^PSIVOE Q
.K TMP
.S TMP(55.01,""_+ON_","_DFN_","_"",100)="E"
.D FILE^DIE("","TMP")
.K TMP
K PSIVALT S PSIVAC="AD",PSIVALCK="STOP",PSIVREA="D",PSIVAL=$S('+$G(PSGALO):$G(PSIVRES),1:$P($G(^PS(53.3,+PSGALO,0)),U)) D D1^PSIVOPT2,LOG^PSIVORAL
K TMP
S TMP(55.01,""_+ON_","_DFN_","_"",157)=$S($G(PSGALO)=1010:"DD",1:"DA")
S TMP(55.01,""_+ON_","_DFN_","_"",.03)=PSJDCDT
S TMP(55.01,""_+ON_","_DFN_","_"",121)=1
D FILE^DIE("","TMP")
K TMP
D EN1^PSJHL2(DFN,"OD",+ON_"V","AUTO DC")
S PSJIVDCF=1
Q
;
SIVDIE ; Setup DIE,DA for IV
K DA,DIE,DR S DA=+ON,DA(1)=DFN,DIE="^PS(55,"_DFN_",""IV"","
Q
;
AUDDD ; set up orders for discharge report and purging
S DIS=+VAIP(17,1) I $S('DIS:1,1:$D(^PS(55,"AUDDD",DIS,PSGP))) Q
S X=$$EN^PSGCT(+VAIP(13,1),-1)
F Q=X:0 S Q=$O(^PS(55,PSGP,5,"AUS",Q)) Q:'Q F QQ=0:0 S QQ=$O(^PS(55,PSGP,5,"AUS",Q,QQ)) Q:'QQ I $S($D(^PS(55,PSGP,5,QQ,0)):'$P(^(0),"^",20),1:1) S $P(^(0),"^",20)=DIS,^PS(55,"AUDDD",DIS,PSGP,QQ)=""
Q
;
ENHE ; status from hold to expired
D NOW^%DTC S PSGDT=+$E(%,1,12),DIE="^PS(55,"_PSGP_",5,"
F PSJS=+PSJPAD:0 S PSJS=$O(^PS(55,PSGP,5,"AUS",PSJS)) Q:'PSJS Q:PSJS>PSGDT F PSJDA=0:0 S PSJDA=$O(^PS(55,PSGP,5,"AUS",PSJS,PSJDA)) Q:'PSJDA K DA S DA(1)=PSGP,DA=PSJDA I $D(^PS(55,PSGP,5,DA,0)),$P(^(0),"^",9)="H" S DR="28////E" D ^DIE
Q
;
ENUNDC(PSJDCDT,PSGP,PSJUOW,PSGALO) ; Auto-reinstate orders DC'ed due to a patient movement.
N PSJSYSW0 D NOW^%DTC S PSJUNDC=1,PSGDT=%,PSJFIRST='$D(PSJQUIET),PSJSYSW0=$G(^PS(59.6,+$O(^PS(59.6,"B",+PSJUOW,0)),0))
S PSJS=$O(^PS(55,PSGP,5,"AUS",PSJDCDT-.0002)) F PSGORD=0:0 S PSGORD=$O(^PS(55,PSGP,5,"AUS",+PSJS,PSGORD)) Q:'PSGORD D
.I $P($G(^PS(55,PSGP,5,PSGORD,0)),U,9)["D",$P($G(^(4)),U,11) D DISREIN,ENRI^PSGOERI
.S ^PS(55,"AUE",PSGP,PSGORD)=""
;
S:PSJS="" PSJS=$O(^PS(55,PSGP,"IV","AIS",PSJDCDT-.0002))
F PSGORD=0:0 S PSGORD=$O(^PS(55,PSGP,"IV","AIS",+PSJS,PSGORD)) Q:'PSGORD D
.I $P($G(^PS(55,PSGP,"IV",PSGORD,0)),U,12),$P($G(^(2)),U,7)>PSGDT S P(3)=$P($G(^(0)),U,3) D DISREIN,ENARI^PSIVOPT(PSGP,PSGORD,+PSJUOW,PSGALO)
I $D(^TMP("PSJUNDC")) S ^TMP("PSJUNDC",$J,DFN)=$P(^DPT(DFN,0),"^")_"^"_$G(^DPT(PSGP,.1))_"^"_PSGALO D ^PSJADT2
;
ENKL ;
F UW=0:0 S UW=$O(^PS(53.41,1,1,UW)) Q:'UW D I '$O(^PS(53.41,1,1,0)) K DA S DA=1,DIK="^PS(53.41," D ^DIK
.F PSGP=0:0 S PSGP=$O(^PS(53.41,1,1,UW,1,PSGP)) Q:'PSGP D I '$O(^PS(53.41,1,1,UW,1,0)) K DA S DIK="^PS(53.41,1,1,",DA(1)=1,DA=UW D ^DIK
..F TO=0:0 S TO=$O(^PS(53.41,1,1,UW,1,PSGP,1,TO)) Q:'TO D I '$O(^PS(53.41,1,1,UW,1,PSGP,1,0)) K DA S DA(2)=1,DA(1)=UW,DA=PSGP,DIK="^PS(53.41,1,1,"_UW_",1," D ^DIK
...I '$O(^PS(53.41,1,1,UW,1,PSGP,1,TO,1,0)) K DA S DA(3)=1,DA(2)=UW,DA(1)=PSGP,DA=TO,DIK="^PS(53.41,1,1,"_UW_",1,"_PSGP_",1," D ^DIK
K DA,DIK,P,PSGDT,PSGP,PSGORD,PSJS,PSJUNDC,TO,UW
Q
;
DISREIN ; Display reinstate msg. for first order.
W:PSJFIRST&'$D(DGQUIET) !,"...reinstating Inpatient Medication orders..." S PSJFIRST=0
Q
;
DCIMO(DFN,ON,TYP) ; Check parameter before DC'ing clinic order
N GLO,IMOND,A,CLINIC,APPT,B,C S GLO=$S(TYP="P":"^PS(53.1,",TYP="U":"^PS(55,"_DFN_",5,",TYP="V":"^PS(55,"_PSGP_",""IV"",",1:"") I TYP="" Q 1
S IMOND=$S(TYP="P"!(TYP="V"):"""DSS""",TYP="U":8,1:"") I IMOND="" Q 1
S GLO=GLO_+ON_","_IMOND_")",A=$G(@GLO),CLINIC=$P(A,"^"),APPT=$P(A,"^",2)
Q:'$$CLINIC^PSJBCMA(A) 1
I '$D(^PS(53.46,"B",CLINIC)) Q 1
I $$GET1^DIQ(2,DFN,.351,"I") Q 1 ;p390 .351 Patient DATE OF DEATH
S B=$O(^PS(53.46,"B",CLINIC,"")),C=+$P(^PS(53.46,B,0),"^",3) Q C
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJADT0 5760 printed Dec 13, 2024@02:06:07 Page 2
PSJADT0 ;BIR/CML3,PR,MLM-AUTO DC/HOLD CANCEL ;11 Aug 98 / 8:25 AM
+1 ;;5.0;INPATIENT MEDICATIONS ;**17,111,112,135,181,274,390**;16 DEC 97;Build 7
+2 ;
+3 ;Reference to ^PS(55 supported by DBIA #2191.
+4 ;
ENDC ; dc active orders first, then non-verified orders
+1 if '$DATA(PSJQUIET)&'$DATA(DGQUIET)
WRITE !,"...discontinuing Inpatient Medication orders..."
+2 SET $PIECE(PSJPIND,"^")=""
+3 DO NOW^%DTC
NEW PSJDCDT
SET (PSJDCDT,PSGDT)=+%
SET PSJSYSW0=""
IF PSJFW
SET PSJSYSW=$ORDER(^PS(59.6,"B",PSJFW,0))
if PSJSYSW
SET PSJSYSW0=$GET(^PS(59.6,PSJSYSW,0))
+4 IF PSGALO=1010!(PSGALO=1030)!(PSGALO=1050)
DO AUDDD
+5 DO ENUNM^PSGOU
SET PSGALR=10
SET DIE="^PS(55,"_PSGP_",5,"
if PSJFW
SET PSGTOL=1
SET PSGUOW=PSJFW
SET PSGTOO=1
+6 FOR PSJS=PSGDT:0
SET PSJS=$ORDER(^PS(55,PSGP,5,"AUS",PSJS))
if 'PSJS
QUIT
FOR PSJDA=0:0
SET PSJDA=$ORDER(^PS(55,PSGP,5,"AUS",PSJS,PSJDA))
if 'PSJDA
QUIT
Begin DoDot:1
+7 if '$$DCIMO(PSGP,PSJDA,"U")
QUIT
+8 ;first naked reference below refers to the full global reference to the right of the = sign (inside the $S)
+9 KILL DA
SET DA(1)=PSGP
SET DA=PSJDA
SET PSGAL("C")=0
SET $PIECE(^(2),"^",3)=$SELECT($DATA(^PS(55,PSGP,5,DA,2)):$PIECE(^(2),"^",4),1:"")
+10 DO ^PSGAL5
+11 KILL TMP
+12 SET TMP(55.06,""_PSJDA_","_PSGP_","_"",28)="D"
+13 SET TMP(55.06,""_PSJDA_","_PSGP_","_"",136)=$SELECT(PSGALO=1010:"DD",1:"DA")
+14 DO FILE^DIE("","TMP")
+15 KILL TMP
+16 SET TMP(55.06,""_PSJDA_","_PSGP_","_"",34)=PSJDCDT
+17 SET TMP(55.06,""_PSJDA_","_PSGP_","_"",49)=1
+18 DO FILE^DIE("","TMP")
+19 KILL TMP
+20 DO EN1^PSJHL2(PSGP,"OD",PSJDA_"U","AUTO DC")
+21 IF PSGALO'=1050
SET DA=PSJDA
SET ^PS(55,"AUE",PSGP,DA)=""
IF $PIECE(PSJSYSW0,"^",15)
IF (PSGALO'<1060)
SET $PIECE(^PS(55,PSGP,5,PSJDA,7),"^",1,2)=PSJDCDT_"^D"
DO ENL^PSGVDS
End DoDot:1
+22 SET PSGTOO=2
FOR PSJDA=0:0
SET PSJDA=$ORDER(^PS(53.1,"AC",PSGP,PSJDA))
if 'PSJDA
QUIT
Begin DoDot:1
+23 if '$$DCIMO(PSGP,PSJDA,"P")
QUIT
+24 IF PSGALO'<1060
IF $PIECE(PSJSYSW0,U,15)
IF $PIECE($GET(^PS(53.1,PSJDA,0)),U,9)="N"
KILL DA
DO ENLBL^PSIVOPT(PSGTOL,PSGUOW,DFN,2,+PSJDA,"AD")
+25 KILL DA
SET DA=PSJDA
Begin DoDot:2
+26 KILL TMP
+27 SET TMP(53.1,""_PSJDA_","_"",28)="D"
+28 SET TMP(53.1,""_PSJDA_","_"",42)=1
+29 DO FILE^DIE("","TMP")
+30 KILL TMP
End DoDot:2
IF $PIECE($GET(^PS(53.1,DA,0)),"^",21)
DO EN1^PSJHL2(PSGP,"OC",PSJDA_"P","AUTO DC")
End DoDot:1
+31 ;
ENIV ;
+1 SET DFN=PSGP
FOR PSJIVON=0:0
SET PSJIVON=$ORDER(^PS(55,DFN,"IV",PSJIVON))
if 'PSJIVON
QUIT
SET Y=$GET(^(PSJIVON,0))
IF "PDEN"'[$PIECE(Y,U,17)
SET P(17)=$PIECE(Y,U,17)
SET P(3)=$PIECE(Y,U,3)
DO DC
+2 QUIT
DC ;
+1 if '$$DCIMO(DFN,PSJIVON,"V")
QUIT
+2 SET (ON,ON55)=PSJIVON_"V"
DO NOW^%DTC
IF P(17)="H"
IF P(3)<%
Begin DoDot:1
+3 KILL TMP
+4 SET TMP(55.01,""_+ON_","_DFN_","_"",100)="E"
+5 DO FILE^DIE("","TMP")
+6 KILL TMP
End DoDot:1
DO EXPIR^PSIVOE
QUIT
+7 KILL PSIVALT
SET PSIVAC="AD"
SET PSIVALCK="STOP"
SET PSIVREA="D"
SET PSIVAL=$SELECT('+$GET(PSGALO):$GET(PSIVRES),1:$PIECE($GET(^PS(53.3,+PSGALO,0)),U))
DO D1^PSIVOPT2
DO LOG^PSIVORAL
+8 KILL TMP
+9 SET TMP(55.01,""_+ON_","_DFN_","_"",157)=$SELECT($GET(PSGALO)=1010:"DD",1:"DA")
+10 SET TMP(55.01,""_+ON_","_DFN_","_"",.03)=PSJDCDT
+11 SET TMP(55.01,""_+ON_","_DFN_","_"",121)=1
+12 DO FILE^DIE("","TMP")
+13 KILL TMP
+14 DO EN1^PSJHL2(DFN,"OD",+ON_"V","AUTO DC")
+15 SET PSJIVDCF=1
+16 QUIT
+17 ;
SIVDIE ; Setup DIE,DA for IV
+1 KILL DA,DIE,DR
SET DA=+ON
SET DA(1)=DFN
SET DIE="^PS(55,"_DFN_",""IV"","
+2 QUIT
+3 ;
AUDDD ; set up orders for discharge report and purging
+1 SET DIS=+VAIP(17,1)
IF $SELECT('DIS:1,1:$DATA(^PS(55,"AUDDD",DIS,PSGP)))
QUIT
+2 SET X=$$EN^PSGCT(+VAIP(13,1),-1)
+3 FOR Q=X:0
SET Q=$ORDER(^PS(55,PSGP,5,"AUS",Q))
if 'Q
QUIT
FOR QQ=0:0
SET QQ=$ORDER(^PS(55,PSGP,5,"AUS",Q,QQ))
if 'QQ
QUIT
IF $SELECT($DATA(^PS(55,PSGP,5,QQ,0)):'$PIECE(^(0),"^",20),1:1)
SET $PIECE(^(0),"^",20)=DIS
SET ^PS(55,"AUDDD",DIS,PSGP,QQ)=""
+4 QUIT
+5 ;
ENHE ; status from hold to expired
+1 DO NOW^%DTC
SET PSGDT=+$EXTRACT(%,1,12)
SET DIE="^PS(55,"_PSGP_",5,"
+2 FOR PSJS=+PSJPAD:0
SET PSJS=$ORDER(^PS(55,PSGP,5,"AUS",PSJS))
if 'PSJS
QUIT
if PSJS>PSGDT
QUIT
FOR PSJDA=0:0
SET PSJDA=$ORDER(^PS(55,PSGP,5,"AUS",PSJS,PSJDA))
if 'PSJDA
QUIT
KILL DA
SET DA(1)=PSGP
SET DA=PSJDA
IF $DATA(^PS(55,PSGP,5,DA,0))
IF $PIECE(^(0),"^",9)="H"
SET DR="28////E"
DO ^DIE
+3 QUIT
+4 ;
ENUNDC(PSJDCDT,PSGP,PSJUOW,PSGALO) ; Auto-reinstate orders DC'ed due to a patient movement.
+1 NEW PSJSYSW0
DO NOW^%DTC
SET PSJUNDC=1
SET PSGDT=%
SET PSJFIRST='$DATA(PSJQUIET)
SET PSJSYSW0=$GET(^PS(59.6,+$ORDER(^PS(59.6,"B",+PSJUOW,0)),0))
+2 SET PSJS=$ORDER(^PS(55,PSGP,5,"AUS",PSJDCDT-.0002))
FOR PSGORD=0:0
SET PSGORD=$ORDER(^PS(55,PSGP,5,"AUS",+PSJS,PSGORD))
if 'PSGORD
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^PS(55,PSGP,5,PSGORD,0)),U,9)["D"
IF $PIECE($GET(^(4)),U,11)
DO DISREIN
DO ENRI^PSGOERI
+4 SET ^PS(55,"AUE",PSGP,PSGORD)=""
End DoDot:1
+5 ;
+6 if PSJS=""
SET PSJS=$ORDER(^PS(55,PSGP,"IV","AIS",PSJDCDT-.0002))
+7 FOR PSGORD=0:0
SET PSGORD=$ORDER(^PS(55,PSGP,"IV","AIS",+PSJS,PSGORD))
if 'PSGORD
QUIT
Begin DoDot:1
+8 IF $PIECE($GET(^PS(55,PSGP,"IV",PSGORD,0)),U,12)
IF $PIECE($GET(^(2)),U,7)>PSGDT
SET P(3)=$PIECE($GET(^(0)),U,3)
DO DISREIN
DO ENARI^PSIVOPT(PSGP,PSGORD,+PSJUOW,PSGALO)
End DoDot:1
+9 IF $DATA(^TMP("PSJUNDC"))
SET ^TMP("PSJUNDC",$JOB,DFN)=$PIECE(^DPT(DFN,0),"^")_"^"_$GET(^DPT(PSGP,.1))_"^"_PSGALO
DO ^PSJADT2
+10 ;
ENKL ;
+1 FOR UW=0:0
SET UW=$ORDER(^PS(53.41,1,1,UW))
if 'UW
QUIT
Begin DoDot:1
+2 FOR PSGP=0:0
SET PSGP=$ORDER(^PS(53.41,1,1,UW,1,PSGP))
if 'PSGP
QUIT
Begin DoDot:2
+3 FOR TO=0:0
SET TO=$ORDER(^PS(53.41,1,1,UW,1,PSGP,1,TO))
if 'TO
QUIT
Begin DoDot:3
+4 IF '$ORDER(^PS(53.41,1,1,UW,1,PSGP,1,TO,1,0))
KILL DA
SET DA(3)=1
SET DA(2)=UW
SET DA(1)=PSGP
SET DA=TO
SET DIK="^PS(53.41,1,1,"_UW_",1,"_PSGP_",1,"
DO ^DIK
End DoDot:3
IF '$ORDER(^PS(53.41,1,1,UW,1,PSGP,1,0))
KILL DA
SET DA(2)=1
SET DA(1)=UW
SET DA=PSGP
SET DIK="^PS(53.41,1,1,"_UW_",1,"
DO ^DIK
End DoDot:2
IF '$ORDER(^PS(53.41,1,1,UW,1,0))
KILL DA
SET DIK="^PS(53.41,1,1,"
SET DA(1)=1
SET DA=UW
DO ^DIK
End DoDot:1
IF '$ORDER(^PS(53.41,1,1,0))
KILL DA
SET DA=1
SET DIK="^PS(53.41,"
DO ^DIK
+5 KILL DA,DIK,P,PSGDT,PSGP,PSGORD,PSJS,PSJUNDC,TO,UW
+6 QUIT
+7 ;
DISREIN ; Display reinstate msg. for first order.
+1 if PSJFIRST&'$DATA(DGQUIET)
WRITE !,"...reinstating Inpatient Medication orders..."
SET PSJFIRST=0
+2 QUIT
+3 ;
DCIMO(DFN,ON,TYP) ; Check parameter before DC'ing clinic order
+1 NEW GLO,IMOND,A,CLINIC,APPT,B,C
SET GLO=$SELECT(TYP="P":"^PS(53.1,",TYP="U":"^PS(55,"_DFN_",5,",TYP="V":"^PS(55,"_PSGP_",""IV"",",1:"")
IF TYP=""
QUIT 1
+2 SET IMOND=$SELECT(TYP="P"!(TYP="V"):"""DSS""",TYP="U":8,1:"")
IF IMOND=""
QUIT 1
+3 SET GLO=GLO_+ON_","_IMOND_")"
SET A=$GET(@GLO)
SET CLINIC=$PIECE(A,"^")
SET APPT=$PIECE(A,"^",2)
+4 if '$$CLINIC^PSJBCMA(A)
QUIT 1
+5 IF '$DATA(^PS(53.46,"B",CLINIC))
QUIT 1
+6 ;p390 .351 Patient DATE OF DEATH
IF $$GET1^DIQ(2,DFN,.351,"I")
QUIT 1
+7 SET B=$ORDER(^PS(53.46,"B",CLINIC,""))
SET C=+$PIECE(^PS(53.46,B,0),"^",3)
QUIT C
