PSGPLUP0 ;BIR/CML3-UPDATING FOR PSGPLUP OCCURS HERE ;06 AUG 96 / 10:53 PM
;;5.0; INPATIENT MEDICATIONS ;**50,129**;16 DEC 97
;
; Reference to ^PS(55 is supported by DBIA #2191.
; Reference to ^PS(59.7 is supported by DBIA #2181
; Reference to ^DIC(42 is supported by DBIA #1377.
; Reference to ^DPT( is supported by DBIA #10035.
;
ENQ ; check for a previous update, if there is one "unflag" updated orders.
;
I '$$LOCK^PSGPLUTL(PSGPLG,"PSGPL") H 60 G ENQ
D NOW^%DTC S PSJACNWP=1,PSGAU="",PSGDT=%,(PDRG,PN,PST,RB,TM,WDN)="",EST=$S($P(PSGPLTND,"^",13):"A",1:"Z"),PSJACNWP=1
F S PSGX=$Q(^PS(53.5,"AU",PSGPLG)),PSGXP=$P(PSGX,"53.5",2) Q:$P(PSGXP,",",2,3)'=("""AU"","_PSGPLG) D UNFLAG
K PSGP,PSGORD,I,X,PSGX,PSGXP
;
; check each patient in the ward group
;
S X1=$P(PSGPLS,"."),X2=-1 D C^%DTC S PSGPLUPO=X_(PSGPLS#1)
F PSGPLWD=0:0 S (WD,PSGPLWD)=$O(^PS(57.5,"AC",PSGPLWG,PSGPLWD)) Q:'PSGPLWD S WDN=$P($G(^DIC(42,WD,0)),"^") I WDN]"" S PSGPLWDN=$S('WSF:WDN,1:"zns") F PSGP=0:0 S PSGP=$O(^DPT("CN",WDN,PSGP)) Q:'PSGP D UP
;
; check each patient on original Pick List (to catch any that have since moved to a different ward group but had action, for example orders DC'd)
S PSGX="",PSGX=$Q(^PS(53.5,"AC",PSGPLG)),PSGXP=$P(PSGX,"53.5",2) Q:$P(PSGXP,",",2,3)'=("""AC"","_PSGPLG) S PSGP=+$P(PSGX,"^",3) D:$D(^PS(55,"AUE",PSGP)) UP
F S PSGX=$Q(@PSGX) Q:$P(PSGX,",",2,3)'=("""AC"","_PSGPLG) S PSGP=+$P(PSGX,"^",3) D:$D(^PS(55,"AUE",PSGP)) UP
K ^PS(53.5,"AC",PSGPLG) F PSG=.01,.02,.05 K DA,DIK S DIK="^PS(53.5,",DIK(1)=PSG,DA=PSGPLG D EN1^DIK
D NOW^%DTC S $P(^PS(53.5,PSGPLG,0),"^",10)=%
;
DONE ;
D UNLOCK^PSGPLUTL(PSGPLG,"PSGPL") K %,%X,%Y,DA,DIK,DRG,EST,NST,PSJJORD,PN,PSGPLO,PSGAU,PSGNDATE,PSGPLS,PSGPLUPO,PSGPLWD
K PSGPLWDN,PSGX,PSGXP,PST,PSGUP,PSGORD,PSJACNWP,RB,SD,TM,X,X1,X2 Q
;
UP ; if patient has an update (AUE xref on UD subfile), add order and drug multiples to Pick List and flag as updated.
; if patient not on last pick list (i.e., transferred or admitted
; and has no orders, add to Pick List patient multiple and flag as updated (do PATIENT^PSGPL1).
D ^PSJAC,ENUNM^PSGOU
S DFN=PSGP,WD=0,WDN=$G(^DPT(PSGP,.1)),RB=$G(^DPT(PSGP,.101)) S:WDN]"" WD=+$O(^DIC(42,"B",WDN,0))
S TM=$S(RB="":"",1:$P($G(^PS(57.7,WD,1,+$O(^PS(57.7,"AWRT",WD,RB,0)),0)),"^"))
F X="RB","TM","WDN" S:@X="" @X="zz"
; check to see if pat has moved to a new ward group, if so leave location alone on this PL and print only orders newly DC'd
; Determine if patient is on the same or different ward group
; (GRP=1:Same,GRP=0:Different)
S GRP=1 I WD S GRP=$O(^PS(57.5,"AB",WD,0)) Q:'GRP S GRP=GRP=$P(^PS(53.5,PSGPLG,0),U,2)
S PN=$P(PSGP(0),"^"),PN=$S(PN]"":$E(PN,1,12),1:PSGP)_"^"_PSGP
I WD,GRP,$G(^PS(53.5,PSGPLG,1,PSGP,0)) S $P(^PS(53.5,PSGPLG,1,PSGP,0),U,2,4)=TM_U_WDN_U_RB
I GRP,'$G(^PS(53.5,PSGPLG,1,PSGP,0)) S PSGAU=1 D PATIENT^PSGPL1
;
;Update orders already on PL for this patient.
N PSJSITE,PSJPRN S PSJSITE=0,PSJSITE=$O(^PS(59.7,PSJSITE)) I $P($G(^(PSJSITE,26)),U,5)=1 S PSJPRN=1
I GRP F PSJJORD=0:0 S PSJJORD=$O(^PS(55,"AUE",PSGP,PSJJORD)) Q:'PSJJORD I $D(^PS(55,PSGP,5,PSJJORD,0)),$D(^(2)) S SD=$P(^(2),"^",4) I (SD'<PSGPLUPO)!($D(^PS(53.5,PSGPLG,1,PSGP,1,"B",PSJJORD))) D UP1
;
;If patient is on a different WG update only DE orders.
I 'GRP D NOW^%DTC S PSGDT=%,X1=$P(PSGPLS,"."),X2=-1 D C^%DTC S PSGPLD=X_(PSGPLS#1) D
.F PST="C","O","OC","P","R" F SD=PSGPLD:0 S SD=$O(^PS(55,PSGP,5,"AU",PST,SD)) Q:'SD F PSJJORD=0:0 S PSJJORD=$O(^PS(55,PSGP,5,"AU",PST,SD,PSJJORD)) Q:'PSJJORD D
..I $D(^PS(53.5,PSGPLG,1,PSGP,1,"B",PSJJORD)) S PSGNDATE=$S($P(^PS(53.5,PSGPLG,0),"^",10)]"":$P(^PS(53.5,PSGPLG,0),"^",10),1:$P(^PS(53.5,PSGPLG,0),"^",9)) I SD>PSGNDATE D UP1
Q
;
UP1 ;
S (NST,PST)=$P(^PS(55,PSGP,5,PSJJORD,0),"^",7) Q:(NST="")!(('GRP)&("DE"'[$P(^PS(55,PSGP,5,PSJJORD,0),"^",9))) S PSGPLO=PSJJORD D ENASET Q
Q
;
ENASET ;
; if you're adding an order that is already on the PL, delete the old one first
I $D(^PS(53.5,PSGPLG,1,PSGP,1,"B",PSJJORD)) D D ^DIK K DIK
.N PSGOST S PSGOST=$P($$LASTREN^PSJLMPRI(PSGP,PSJJORD_"U"),"^",4) I PSGOST D
..N PSGPLS,PSGPLF S PSGPLS=$P(PSGPLTND,"^",3),PSGPLF=$P(PSGPLTND,"^",4) I PSGOST>PSGPLS&(PSGOST<PSGPLF) D
...N PSGPLO S PSGPLO=$O(^PS(53.5,PSGPLG,1,PSGP,1,"B",PSJJORD,999),-1)
...M PSGPLREN(53.5,PSGPLG,1,PSGP,1,PSGPLO)=^PS(53.5,PSGPLG,1,PSGP,1,PSGPLO) S PSGPLREN("B",PSGP,PSJJORD,PSGPLO)=PSGOST
...N PSGPLX F PSGPLX="AC","AU" M PSGPLREN(53.5,PSGPLX,PSGPLG)=^PS(53.5,PSGPLX,PSGPLG)
.K DA,DIK S DA=$O(^PS(53.5,PSGPLG,1,PSGP,1,"B",PSJJORD,0)),DA(2)=PSGPLG,DA(1)=PSGP,DIK="^PS(53.5,"_PSGPLG_",1,"_PSGP_",1,"
.S:$D(^PS(53.5,DA(2),1,DA(1),0)) $P(^(0),U,5)=""
.S:$D(^PS(53.5,DA(2),1,DA(1),1,DA,0)) $P(^(0),U,5)=""
; go to ^PSGPL1 to add new orders to the PL. (unless the patient has no ward, in which case he's probably discharged)
N PSGPLWD S PSGPLWD=WD
S (DDC,PSGAU)=1 D ENASET^PSGPL1 S DR=".05////1",DIE="^PS(53.5,"_PSGPLG_",1,"_PSGP_",1,",DA(2)=PSGPLG,DA(1)=PSGP,DA=PSGORD D ^DIE K DIE
Q
UNFLAG ; unset "old" update flag
;
S PSGP=+$P(PSGX,"^",3),PSGORD=+$P(PSGX,"^",4)
S $P(^PS(53.5,PSGPLG,1,PSGP,0),"^",5)="" K @PSGX
S:PSGORD $P(^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,0),"^",5)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGPLUP0 5254 printed Nov 22, 2024@17:13:03 Page 2
PSGPLUP0 ;BIR/CML3-UPDATING FOR PSGPLUP OCCURS HERE ;06 AUG 96 / 10:53 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**50,129**;16 DEC 97
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA #2191.
+4 ; Reference to ^PS(59.7 is supported by DBIA #2181
+5 ; Reference to ^DIC(42 is supported by DBIA #1377.
+6 ; Reference to ^DPT( is supported by DBIA #10035.
+7 ;
ENQ ; check for a previous update, if there is one "unflag" updated orders.
+1 ;
+2 IF '$$LOCK^PSGPLUTL(PSGPLG,"PSGPL")
HANG 60
GOTO ENQ
+3 DO NOW^%DTC
SET PSJACNWP=1
SET PSGAU=""
SET PSGDT=%
SET (PDRG,PN,PST,RB,TM,WDN)=""
SET EST=$SELECT($PIECE(PSGPLTND,"^",13):"A",1:"Z")
SET PSJACNWP=1
+4 FOR
SET PSGX=$QUERY(^PS(53.5,"AU",PSGPLG))
SET PSGXP=$PIECE(PSGX,"53.5",2)
if $PIECE(PSGXP,",",2,3)'=("""AU"","_PSGPLG)
QUIT
DO UNFLAG
+5 KILL PSGP,PSGORD,I,X,PSGX,PSGXP
+6 ;
+7 ; check each patient in the ward group
+8 ;
+9 SET X1=$PIECE(PSGPLS,".")
SET X2=-1
DO C^%DTC
SET PSGPLUPO=X_(PSGPLS#1)
+10 FOR PSGPLWD=0:0
SET (WD,PSGPLWD)=$ORDER(^PS(57.5,"AC",PSGPLWG,PSGPLWD))
if 'PSGPLWD
QUIT
SET WDN=$PIECE($GET(^DIC(42,WD,0)),"^")
IF WDN]""
SET PSGPLWDN=$SELECT('WSF:WDN,1:"zns")
FOR PSGP=0:0
SET PSGP=$ORDER(^DPT("CN",WDN,PSGP))
if 'PSGP
QUIT
DO UP
+11 ;
+12 ; check each patient on original Pick List (to catch any that have since moved to a different ward group but had action, for example orders DC'd)
+13 SET PSGX=""
SET PSGX=$QUERY(^PS(53.5,"AC",PSGPLG))
SET PSGXP=$PIECE(PSGX,"53.5",2)
if $PIECE(PSGXP,",",2,3)'=("""AC"","_PSGPLG)
QUIT
SET PSGP=+$PIECE(PSGX,"^",3)
if $DATA(^PS(55,"AUE",PSGP))
DO UP
+14 FOR
SET PSGX=$QUERY(@PSGX)
if $PIECE(PSGX,",",2,3)'=("""AC"","_PSGPLG)
QUIT
SET PSGP=+$PIECE(PSGX,"^",3)
if $DATA(^PS(55,"AUE",PSGP))
DO UP
+15 KILL ^PS(53.5,"AC",PSGPLG)
FOR PSG=.01,.02,.05
KILL DA,DIK
SET DIK="^PS(53.5,"
SET DIK(1)=PSG
SET DA=PSGPLG
DO EN1^DIK
+16 DO NOW^%DTC
SET $PIECE(^PS(53.5,PSGPLG,0),"^",10)=%
+17 ;
DONE ;
+1 DO UNLOCK^PSGPLUTL(PSGPLG,"PSGPL")
KILL %,%X,%Y,DA,DIK,DRG,EST,NST,PSJJORD,PN,PSGPLO,PSGAU,PSGNDATE,PSGPLS,PSGPLUPO,PSGPLWD
+2 KILL PSGPLWDN,PSGX,PSGXP,PST,PSGUP,PSGORD,PSJACNWP,RB,SD,TM,X,X1,X2
QUIT
+3 ;
UP ; if patient has an update (AUE xref on UD subfile), add order and drug multiples to Pick List and flag as updated.
+1 ; if patient not on last pick list (i.e., transferred or admitted
+2 ; and has no orders, add to Pick List patient multiple and flag as updated (do PATIENT^PSGPL1).
+3 DO ^PSJAC
DO ENUNM^PSGOU
+4 SET DFN=PSGP
SET WD=0
SET WDN=$GET(^DPT(PSGP,.1))
SET RB=$GET(^DPT(PSGP,.101))
if WDN]""
SET WD=+$ORDER(^DIC(42,"B",WDN,0))
+5 SET TM=$SELECT(RB="":"",1:$PIECE($GET(^PS(57.7,WD,1,+$ORDER(^PS(57.7,"AWRT",WD,RB,0)),0)),"^"))
+6 FOR X="RB","TM","WDN"
if @X=""
SET @X="zz"
+7 ; check to see if pat has moved to a new ward group, if so leave location alone on this PL and print only orders newly DC'd
+8 ; Determine if patient is on the same or different ward group
+9 ; (GRP=1:Same,GRP=0:Different)
+10 SET GRP=1
IF WD
SET GRP=$ORDER(^PS(57.5,"AB",WD,0))
if 'GRP
QUIT
SET GRP=GRP=$PIECE(^PS(53.5,PSGPLG,0),U,2)
+11 SET PN=$PIECE(PSGP(0),"^")
SET PN=$SELECT(PN]"":$EXTRACT(PN,1,12),1:PSGP)_"^"_PSGP
+12 IF WD
IF GRP
IF $GET(^PS(53.5,PSGPLG,1,PSGP,0))
SET $PIECE(^PS(53.5,PSGPLG,1,PSGP,0),U,2,4)=TM_U_WDN_U_RB
+13 IF GRP
IF '$GET(^PS(53.5,PSGPLG,1,PSGP,0))
SET PSGAU=1
DO PATIENT^PSGPL1
+14 ;
+15 ;Update orders already on PL for this patient.
+16 NEW PSJSITE,PSJPRN
SET PSJSITE=0
SET PSJSITE=$ORDER(^PS(59.7,PSJSITE))
IF $PIECE($GET(^(PSJSITE,26)),U,5)=1
SET PSJPRN=1
+17 IF GRP
FOR PSJJORD=0:0
SET PSJJORD=$ORDER(^PS(55,"AUE",PSGP,PSJJORD))
if 'PSJJORD
QUIT
IF $DATA(^PS(55,PSGP,5,PSJJORD,0))
IF $DATA(^(2))
SET SD=$PIECE(^(2),"^",4)
IF (SD'<PSGPLUPO)!($DATA(^PS(53.5,PSGPLG,1,PSGP,1,"B",PSJJORD)))
DO UP1
+18 ;
+19 ;If patient is on a different WG update only DE orders.
+20 IF 'GRP
DO NOW^%DTC
SET PSGDT=%
SET X1=$PIECE(PSGPLS,".")
SET X2=-1
DO C^%DTC
SET PSGPLD=X_(PSGPLS#1)
Begin DoDot:1
+21 FOR PST="C","O","OC","P","R"
FOR SD=PSGPLD:0
SET SD=$ORDER(^PS(55,PSGP,5,"AU",PST,SD))
if 'SD
QUIT
FOR PSJJORD=0:0
SET PSJJORD=$ORDER(^PS(55,PSGP,5,"AU",PST,SD,PSJJORD))
if 'PSJJORD
QUIT
Begin DoDot:2
+22 IF $DATA(^PS(53.5,PSGPLG,1,PSGP,1,"B",PSJJORD))
SET PSGNDATE=$SELECT($PIECE(^PS(53.5,PSGPLG,0),"^",10)]"":$PIECE(^PS(53.5,PSGPLG,0),"^",10),1:$PIECE(^PS(53.5,PSGPLG,0),"^",9))
IF SD>PSGNDATE
DO UP1
End DoDot:2
End DoDot:1
+23 QUIT
+24 ;
UP1 ;
+1 SET (NST,PST)=$PIECE(^PS(55,PSGP,5,PSJJORD,0),"^",7)
if (NST="")!(('GRP)&("DE"'[$PIECE(^PS(55,PSGP,5,PSJJORD,0),"^",9)))
QUIT
SET PSGPLO=PSJJORD
DO ENASET
QUIT
+2 QUIT
+3 ;
ENASET ;
+1 ; if you're adding an order that is already on the PL, delete the old one first
+2 IF $DATA(^PS(53.5,PSGPLG,1,PSGP,1,"B",PSJJORD))
Begin DoDot:1
+3 NEW PSGOST
SET PSGOST=$PIECE($$LASTREN^PSJLMPRI(PSGP,PSJJORD_"U"),"^",4)
IF PSGOST
Begin DoDot:2
+4 NEW PSGPLS,PSGPLF
SET PSGPLS=$PIECE(PSGPLTND,"^",3)
SET PSGPLF=$PIECE(PSGPLTND,"^",4)
IF PSGOST>PSGPLS&(PSGOST<PSGPLF)
Begin DoDot:3
+5 NEW PSGPLO
SET PSGPLO=$ORDER(^PS(53.5,PSGPLG,1,PSGP,1,"B",PSJJORD,999),-1)
+6 MERGE PSGPLREN(53.5,PSGPLG,1,PSGP,1,PSGPLO)=^PS(53.5,PSGPLG,1,PSGP,1,PSGPLO)
SET PSGPLREN("B",PSGP,PSJJORD,PSGPLO)=PSGOST
+7 NEW PSGPLX
FOR PSGPLX="AC","AU"
MERGE PSGPLREN(53.5,PSGPLX,PSGPLG)=^PS(53.5,PSGPLX,PSGPLG)
End DoDot:3
End DoDot:2
+8 KILL DA,DIK
SET DA=$ORDER(^PS(53.5,PSGPLG,1,PSGP,1,"B",PSJJORD,0))
SET DA(2)=PSGPLG
SET DA(1)=PSGP
SET DIK="^PS(53.5,"_PSGPLG_",1,"_PSGP_",1,"
+9 if $DATA(^PS(53.5,DA(2),1,DA(1),0))
SET $PIECE(^(0),U,5)=""
+10 if $DATA(^PS(53.5,DA(2),1,DA(1),1,DA,0))
SET $PIECE(^(0),U,5)=""
End DoDot:1
DO ^DIK
KILL DIK
+11 ; go to ^PSGPL1 to add new orders to the PL. (unless the patient has no ward, in which case he's probably discharged)
+12 NEW PSGPLWD
SET PSGPLWD=WD
+13 SET (DDC,PSGAU)=1
DO ENASET^PSGPL1
SET DR=".05////1"
SET DIE="^PS(53.5,"_PSGPLG_",1,"_PSGP_",1,"
SET DA(2)=PSGPLG
SET DA(1)=PSGP
SET DA=PSGORD
DO ^DIE
KILL DIE
+14 QUIT
UNFLAG ; unset "old" update flag
+1 ;
+2 SET PSGP=+$PIECE(PSGX,"^",3)
SET PSGORD=+$PIECE(PSGX,"^",4)
+3 SET $PIECE(^PS(53.5,PSGPLG,1,PSGP,0),"^",5)=""
KILL @PSGX
+4 if PSGORD
SET $PIECE(^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,0),"^",5)=""
+5 QUIT
