- PSGPL1 ;BIR/CML3-GATHER PICK LIST DATA ;26 JAN 99 / 9:30 AM
- ;;5.0; INPATIENT MEDICATIONS ;**25,50**;16 DEC 97
- ;
- ; Reference to ^PSI(58.1 is supported by DBIA# 2284.
- ; Reference to ^PS(55 is supported by DBIA# 2191.
- ; Reference to ^PSD(58.8 is supported by DBIA# 2283.
- ; Reference to ^DIC(42 is supported by DBIA# 10039.
- ;
- EN ; entry point for PSGPL - get ward info, loop thru patients
- N PRINT S PRINT=0
- I $G(RERUN)=2,$D(OG) D
- .F I $$LOCK^PSGPLUTL(OG,"PSGPL") Q
- .K DA,DIK S DIK="^PS(53.5,",DA=OG D ^DIK K DIK I $D(^PS(57.5,PSGPLWG,2)),+^(2)=OG S ^(2)=$P(^(2),"^",6,20)
- F I $$LOCK^PSGPLUTL(PSGPLG,"PSGPL") Q
- S PSGPLTND=$G(^PS(53.5,PSGPLG,0)) G:PSGPLTND="" DONE S WSF=$P(PSGPLTND,"^",7),EST=$S($P(PSGPLTND,"^",13):"A",1:"Z")
- D NOW^%DTC S PSGDT=%,X1=$P(PSGPLS,"."),X2=-1 D C^%DTC S PSGPLD=X_(PSGPLS#1)
- F PSGPLWD=0:0 S PSGPLWD=$O(^PS(57.5,"AC",PSGPLWG,PSGPLWD)) Q:'PSGPLWD S WDN=$P($G(^DIC(42,PSGPLWD,0)),"^") I WDN]"" D
- .S PSGPLWDN=$S('WSF:WDN,1:"zns") F PSGP=0:0 S PSGP=$O(^DPT("CN",WDN,PSGP)) Q:'PSGP S PSJACNWP=1 D ^PSJAC,ENUNM^PSGOU D
- ..S TM="zz",RB=PSJPRB S:RB="" RB="zz" I RB'="zz" S X=+$O(^PS(57.7,"AWRT",PSGPLWD,RB,0)) I X,$D(^PS(57.7,PSGPLWD,1,X,0)),$P(^(0),"^")]"" S TM=$P(^(0),"^")
- ..S PSJJORD=0 D PATIENT Q:'$O(^PS(55,PSGP,5,"AUS",PSGPLS))
- ..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 ENASET
- ;
- I $D(^PS(53.5,PSGPLG)) S DIK="^PS(53.5,",DA=PSGPLG D
- .F DIK(1)=.01,.02,.05 D EN1^DIK
- .K DIK D NOW^%DTC S $P(^PS(53.5,PSGPLG,0),"^",9)=% S:IO]"" PRINT=1
- ;
- DONE ;
- D UNLOCK^PSGPLUTL(PSGPLG,"PSGPL")
- D:PRINT ^PSGPLR
- D ^%ZISC,ENKV^PSGSETU K DRG,PSGP,PSGORD,PN,PSGPLC,PSGPLD,PSGPLO,PSGPLTND,PSGPLWD,PSGPLWDN,PSGMAR,PSJACNWP,PSJJORD,PSGLOCK,P,ST,SD,TM,WSF,DDC Q
- ;
- ENASET ; this tag can be called from above or from update (^PSGPLUP0)
- ; if order not being edited (OE), on hold (HD), non-verified (NV) or self-med (SM) get units (^PSGPL0)
- S PSGPLDC="",PSGLOCK="",NST=$S(SD<PSGPLS:EST,1:PST)
- L +^PS(55,PSGP,5,PSJJORD):1 I K ^PS(55,"AUE",PSGP,PSJJORD) S PSGLOCK=1
- G:NST=EST A1
- S PSGPLDC=$S('PSGLOCK:"OE",$P($G(^PS(55,PSGP,5,PSJJORD,0)),"^",9)="H":"HD",$P($G(^(0)),"^",5):"SM",'$P($G(^PS(55,PSGP,5,PSJJORD,4)),"^",9):"NV",1:"")
- ;
- A1 ; if there are orders, set the order and drug multiples.
- ; PSJJORD = unit dose subfile order ien
- ; PSGORD = PL order multiple ien
- ; DRG = unit dose subfile dispense drug multiple ien
- ; PSGDRG = PL dispense drug multiple ien
- I '$D(^PS(53.5,PSGPLG,1,PSGP,1)) S ^(1,0)="^53.52A^0^0"
- S PSGORD=(+$P(^PS(53.5,PSGPLG,1,PSGP,1,0),"^",3)+1),$P(^(0),"^",3,4)=PSGORD_"^"_(+$P(^(0),"^",4)+1)
- S ^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,0)=PSJJORD_"^"_NST_"^"_"^"_PSGPLDC,$P(^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,0),U,6)=$P($G(^PS(55,PSGP,5,PSJJORD,.2)),"^"),^PS(53.5,PSGPLG,1,PSGP,1,"B",PSJJORD,PSGORD)=""
- I $D(^PS(55,PSGP,5,PSJJORD,1))=10 S DDC=0 F DRG=0:0 S DRG=$O(^PS(55,PSGP,5,PSJJORD,1,DRG)) Q:'DRG S DND=$G(^(DRG,0)) I DND D
- .S:PSGPLDC]"" PSGPLC=PSGPLDC I PSGPLDC="" S PSGPLO=PSJJORD D ^PSGPL0
- .I '$D(^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1)) S ^(1,0)="^53.53A^0^0"
- .S PSGDRG=(+$P(^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1,0),"^",3)+1),$P(^(0),"^",3,4)=PSGDRG_"^"_(+$P(^(0),"^",4)+1)
- .I PSGPLDC'?1.A S PSGPLC=$$WS^PSGPL1(+DND,+PSGPLWD,PSGPLC,PSGDT)
- .I $S($P(DND,"^",3):$P(DND,"^",3)\1'>PSGPLF,1:NST=EST) S ^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1,PSGDRG,0)=DRG_"^"_$S(NST=EST:"",1:$P(DND,"^",3)\1_"DI"),^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1,"B",DRG,PSGDRG)="",DDC=DDC+1 Q
- .S ^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1,PSGDRG,0)=DRG_"^"_$S(PSGPLC&$P(DND,"^",2):PSGPLC*$S($P($P(DND,"^",2),".",2)]"":$P($P(DND,"^",2),".")+1,1:$P(DND,"^",2)),1:PSGPLC),^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1,"B",DRG,PSGDRG)="",DDC=DDC+1
- I PSGLOCK L -^PS(55,PSGP,5,PSJJORD)
- K PSGDRG Q
- PATIENT ; add a patient to Pick List. Can also be called from ^PSGPLUP0.
- I '$D(^PS(53.5,PSGPLG,1)) S ^(1,0)="^53.51PA^0^0"
- S $P(^(0),"^",3,4)=PSGP_"^"_($P(^PS(53.5,PSGPLG,1,0),"^",4)+1)
- ;The naked indicator on the line above references the global reference to the right of the equal sign.
- S ^PS(53.5,PSGPLG,1,PSGP,0)=PSGP_"^"_TM_"^"_WDN_"^"_RB,^PS(53.5,PSGPLG,1,"B",PSGP,PSGP)=""
- I $G(PSGAU)=1 S DR=".05////1",DIE="^PS(53.5,"_PSGPLG_",1,",DA(1)=PSGPLG,DA=PSGP D ^DIE K DIE
- Q
- WS(DND,WD,PSGPLC,PSGDT) ;
- N AOU,DRUG
- F F="^PSD(58.8,","^PSI(58.1," I $D(@(F_"""D"","_DND_","_WD_")")) D
- .F AOU=0:0 S AOU=$O(@(F_"""D"","_DND_","_WD_","_AOU_")")) Q:'AOU!(PSGPLC="WS") D
- ..S DRUG=$O(@(F_AOU_",1,""B"","_DND_",0)")) Q:'DRUG S X=$P($G(^(DRUG,0)),U,3) I 'X!(X>PSGDT) S PSGPLC="WS"
- Q PSGPLC
- PSGPL1 ;BIR/CML3-GATHER PICK LIST DATA ;26 JAN 99 / 9:30 AM
- +1 ;;5.0; INPATIENT MEDICATIONS ;**25,50**;16 DEC 97
- +2 ;
- +3 ; Reference to ^PSI(58.1 is supported by DBIA# 2284.
- +4 ; Reference to ^PS(55 is supported by DBIA# 2191.
- +5 ; Reference to ^PSD(58.8 is supported by DBIA# 2283.
- +6 ; Reference to ^DIC(42 is supported by DBIA# 10039.
- +7 ;
- EN ; entry point for PSGPL - get ward info, loop thru patients
- +1 NEW PRINT
- SET PRINT=0
- +2 IF $GET(RERUN)=2
- IF $DATA(OG)
- Begin DoDot:1
- +3 FOR
- IF $$LOCK^PSGPLUTL(OG,"PSGPL")
- QUIT
- +4 KILL DA,DIK
- SET DIK="^PS(53.5,"
- SET DA=OG
- DO ^DIK
- KILL DIK
- IF $DATA(^PS(57.5,PSGPLWG,2))
- IF +^(2)=OG
- SET ^(2)=$PIECE(^(2),"^",6,20)
- End DoDot:1
- +5 FOR
- IF $$LOCK^PSGPLUTL(PSGPLG,"PSGPL")
- QUIT
- +6 SET PSGPLTND=$GET(^PS(53.5,PSGPLG,0))
- IF PSGPLTND=""
- GOTO DONE
- SET WSF=$PIECE(PSGPLTND,"^",7)
- SET EST=$SELECT($PIECE(PSGPLTND,"^",13):"A",1:"Z")
- +7 DO NOW^%DTC
- SET PSGDT=%
- SET X1=$PIECE(PSGPLS,".")
- SET X2=-1
- DO C^%DTC
- SET PSGPLD=X_(PSGPLS#1)
- +8 FOR PSGPLWD=0:0
- SET PSGPLWD=$ORDER(^PS(57.5,"AC",PSGPLWG,PSGPLWD))
- IF 'PSGPLWD
- QUIT
- SET WDN=$PIECE($GET(^DIC(42,PSGPLWD,0)),"^")
- IF WDN]""
- Begin DoDot:1
- +9 SET PSGPLWDN=$SELECT('WSF:WDN,1:"zns")
- FOR PSGP=0:0
- SET PSGP=$ORDER(^DPT("CN",WDN,PSGP))
- IF 'PSGP
- QUIT
- SET PSJACNWP=1
- DO ^PSJAC
- DO ENUNM^PSGOU
- Begin DoDot:2
- +10 SET TM="zz"
- SET RB=PSJPRB
- IF RB=""
- SET RB="zz"
- IF RB'="zz"
- SET X=+$ORDER(^PS(57.7,"AWRT",PSGPLWD,RB,0))
- IF X
- IF $DATA(^PS(57.7,PSGPLWD,1,X,0))
- IF $PIECE(^(0),"^")]""
- SET TM=$PIECE(^(0),"^")
- +11 SET PSJJORD=0
- DO PATIENT
- IF '$ORDER(^PS(55,PSGP,5,"AUS",PSGPLS))
- QUIT
- +12 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
- DO ENASET
- End DoDot:2
- End DoDot:1
- +13 ;
- +14 IF $DATA(^PS(53.5,PSGPLG))
- SET DIK="^PS(53.5,"
- SET DA=PSGPLG
- Begin DoDot:1
- +15 FOR DIK(1)=.01,.02,.05
- DO EN1^DIK
- +16 KILL DIK
- DO NOW^%DTC
- SET $PIECE(^PS(53.5,PSGPLG,0),"^",9)=%
- IF IO]""
- SET PRINT=1
- End DoDot:1
- +17 ;
- DONE ;
- +1 DO UNLOCK^PSGPLUTL(PSGPLG,"PSGPL")
- +2 IF PRINT
- DO ^PSGPLR
- +3 DO ^%ZISC
- DO ENKV^PSGSETU
- KILL DRG,PSGP,PSGORD,PN,PSGPLC,PSGPLD,PSGPLO,PSGPLTND,PSGPLWD,PSGPLWDN,PSGMAR,PSJACNWP,PSJJORD,PSGLOCK,P,ST,SD,TM,WSF,DDC
- QUIT
- +4 ;
- ENASET ; this tag can be called from above or from update (^PSGPLUP0)
- +1 ; if order not being edited (OE), on hold (HD), non-verified (NV) or self-med (SM) get units (^PSGPL0)
- +2 SET PSGPLDC=""
- SET PSGLOCK=""
- SET NST=$SELECT(SD<PSGPLS:EST,1:PST)
- +3 LOCK +^PS(55,PSGP,5,PSJJORD):1
- IF $TEST
- KILL ^PS(55,"AUE",PSGP,PSJJORD)
- SET PSGLOCK=1
- +4 IF NST=EST
- GOTO A1
- +5 SET PSGPLDC=$SELECT('PSGLOCK:"OE",$PIECE($GET(^PS(55,PSGP,5,PSJJORD,0)),"^",9)="H":"HD",$PIECE($GET(^(0)),"^",5):"SM",'$PIECE($GET(^PS(55,PSGP,5,PSJJORD,4)),"^",9):"NV",1:"")
- +6 ;
- A1 ; if there are orders, set the order and drug multiples.
- +1 ; PSJJORD = unit dose subfile order ien
- +2 ; PSGORD = PL order multiple ien
- +3 ; DRG = unit dose subfile dispense drug multiple ien
- +4 ; PSGDRG = PL dispense drug multiple ien
- +5 IF '$DATA(^PS(53.5,PSGPLG,1,PSGP,1))
- SET ^(1,0)="^53.52A^0^0"
- +6 SET PSGORD=(+$PIECE(^PS(53.5,PSGPLG,1,PSGP,1,0),"^",3)+1)
- SET $PIECE(^(0),"^",3,4)=PSGORD_"^"_(+$PIECE(^(0),"^",4)+1)
- +7 SET ^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,0)=PSJJORD_"^"_NST_"^"_"^"_PSGPLDC
- SET $PIECE(^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,0),U,6)=$PIECE($GET(^PS(55,PSGP,5,PSJJORD,.2)),"^")
- SET ^PS(53.5,PSGPLG,1,PSGP,1,"B",PSJJORD,PSGORD)=""
- +8 IF $DATA(^PS(55,PSGP,5,PSJJORD,1))=10
- SET DDC=0
- FOR DRG=0:0
- SET DRG=$ORDER(^PS(55,PSGP,5,PSJJORD,1,DRG))
- IF 'DRG
- QUIT
- SET DND=$GET(^(DRG,0))
- IF DND
- Begin DoDot:1
- +9 IF PSGPLDC]""
- SET PSGPLC=PSGPLDC
- IF PSGPLDC=""
- SET PSGPLO=PSJJORD
- DO ^PSGPL0
- +10 IF '$DATA(^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1))
- SET ^(1,0)="^53.53A^0^0"
- +11 SET PSGDRG=(+$PIECE(^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1,0),"^",3)+1)
- SET $PIECE(^(0),"^",3,4)=PSGDRG_"^"_(+$PIECE(^(0),"^",4)+1)
- +12 IF PSGPLDC'?1.A
- SET PSGPLC=$$WS^PSGPL1(+DND,+PSGPLWD,PSGPLC,PSGDT)
- +13 IF $SELECT($PIECE(DND,"^",3):$PIECE(DND,"^",3)\1'>PSGPLF,1:NST=EST)
- SET ^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1,PSGDRG,0)=DRG_"^"_$SELECT(NST=EST:"",1:$PIECE(DND,"^",3)\1_"DI")
- SET ^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1,"B",DRG,PSGDRG)=""
- SET DDC=DDC+1
- QUIT
- +14 SET ^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1,PSGDRG,0)=DRG_"^"_$SELECT(PSGPLC&$PIECE(DND,"^",2):PSGPLC*$SELECT($PIECE($PIECE(DND,"^",2),".",2)]"":$PIECE($PIECE(DND,"^",2),".")+1,1:$PIECE(DND,"^",2)),1:PSGPLC)
- SET ^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1,"B",DRG,PSGDRG)=""
- SET DDC=DDC+1
- End DoDot:1
- +15 IF PSGLOCK
- LOCK -^PS(55,PSGP,5,PSJJORD)
- +16 KILL PSGDRG
- QUIT
- PATIENT ; add a patient to Pick List. Can also be called from ^PSGPLUP0.
- +1 IF '$DATA(^PS(53.5,PSGPLG,1))
- SET ^(1,0)="^53.51PA^0^0"
- +2 SET $PIECE(^(0),"^",3,4)=PSGP_"^"_($PIECE(^PS(53.5,PSGPLG,1,0),"^",4)+1)
- +3 ;The naked indicator on the line above references the global reference to the right of the equal sign.
- +4 SET ^PS(53.5,PSGPLG,1,PSGP,0)=PSGP_"^"_TM_"^"_WDN_"^"_RB
- SET ^PS(53.5,PSGPLG,1,"B",PSGP,PSGP)=""
- +5 IF $GET(PSGAU)=1
- SET DR=".05////1"
- SET DIE="^PS(53.5,"_PSGPLG_",1,"
- SET DA(1)=PSGPLG
- SET DA=PSGP
- DO ^DIE
- KILL DIE
- +6 QUIT
- WS(DND,WD,PSGPLC,PSGDT) ;
- +1 NEW AOU,DRUG
- +2 FOR F="^PSD(58.8,","^PSI(58.1,"
- IF $DATA(@(F_"""D"","_DND_","_WD_")"))
- Begin DoDot:1
- +3 FOR AOU=0:0
- SET AOU=$ORDER(@(F_"""D"","_DND_","_WD_","_AOU_")"))
- IF 'AOU!(PSGPLC="WS")
- QUIT
- Begin DoDot:2
- +4 SET DRUG=$ORDER(@(F_AOU_",1,""B"","_DND_",0)"))
- IF 'DRUG
- QUIT
- SET X=$PIECE($GET(^(DRUG,0)),U,3)
- IF 'X!(X>PSGDT)
- SET PSGPLC="WS"
- End DoDot:2
- End DoDot:1
- +5 QUIT PSGPLC
