Routine: PSGPLUP0

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

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

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

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)=""

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

PSGPLUP0.m