source: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGPL1.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.5 KB
Line 
1PSGPL1 ;BIR/CML3-GATHER PICK LIST DATA ;26 JAN 99 / 9:30 AM
2 ;;5.0; INPATIENT MEDICATIONS ;**25,50**;16 DEC 97
3 ;
4 ; Reference to ^PSI(58.1 is supported by DBIA# 2284.
5 ; Reference to ^PS(55 is supported by DBIA# 2191.
6 ; Reference to ^PSD(58.8 is supported by DBIA# 2283.
7 ; Reference to ^DIC(42 is supported by DBIA# 10039.
8 ;
9EN ; entry point for PSGPL - get ward info, loop thru patients
10 N PRINT S PRINT=0
11 I $G(RERUN)=2,$D(OG) D
12 .F I $$LOCK^PSGPLUTL(OG,"PSGPL") Q
13 .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)
14 F I $$LOCK^PSGPLUTL(PSGPLG,"PSGPL") Q
15 S PSGPLTND=$G(^PS(53.5,PSGPLG,0)) G:PSGPLTND="" DONE S WSF=$P(PSGPLTND,"^",7),EST=$S($P(PSGPLTND,"^",13):"A",1:"Z")
16 D NOW^%DTC S PSGDT=%,X1=$P(PSGPLS,"."),X2=-1 D C^%DTC S PSGPLD=X_(PSGPLS#1)
17 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
18 .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
19 ..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),"^")
20 ..S PSJJORD=0 D PATIENT Q:'$O(^PS(55,PSGP,5,"AUS",PSGPLS))
21 ..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
22 ;
23 I $D(^PS(53.5,PSGPLG)) S DIK="^PS(53.5,",DA=PSGPLG D
24 .F DIK(1)=.01,.02,.05 D EN1^DIK
25 .K DIK D NOW^%DTC S $P(^PS(53.5,PSGPLG,0),"^",9)=% S:IO]"" PRINT=1
26 ;
27DONE ;
28 D UNLOCK^PSGPLUTL(PSGPLG,"PSGPL")
29 D:PRINT ^PSGPLR
30 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
31 ;
32ENASET ; this tag can be called from above or from update (^PSGPLUP0)
33 ; if order not being edited (OE), on hold (HD), non-verified (NV) or self-med (SM) get units (^PSGPL0)
34 S PSGPLDC="",PSGLOCK="",NST=$S(SD<PSGPLS:EST,1:PST)
35 L +^PS(55,PSGP,5,PSJJORD):1 I K ^PS(55,"AUE",PSGP,PSJJORD) S PSGLOCK=1
36 G:NST=EST A1
37 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:"")
38 ;
39A1 ; if there are orders, set the order and drug multiples.
40 ; PSJJORD = unit dose subfile order ien
41 ; PSGORD = PL order multiple ien
42 ; DRG = unit dose subfile dispense drug multiple ien
43 ; PSGDRG = PL dispense drug multiple ien
44 I '$D(^PS(53.5,PSGPLG,1,PSGP,1)) S ^(1,0)="^53.52A^0^0"
45 S PSGORD=(+$P(^PS(53.5,PSGPLG,1,PSGP,1,0),"^",3)+1),$P(^(0),"^",3,4)=PSGORD_"^"_(+$P(^(0),"^",4)+1)
46 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)=""
47 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
48 .S:PSGPLDC]"" PSGPLC=PSGPLDC I PSGPLDC="" S PSGPLO=PSJJORD D ^PSGPL0
49 .I '$D(^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1)) S ^(1,0)="^53.53A^0^0"
50 .S PSGDRG=(+$P(^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1,0),"^",3)+1),$P(^(0),"^",3,4)=PSGDRG_"^"_(+$P(^(0),"^",4)+1)
51 .I PSGPLDC'?1.A S PSGPLC=$$WS^PSGPL1(+DND,+PSGPLWD,PSGPLC,PSGDT)
52 .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
53 .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
54 I PSGLOCK L -^PS(55,PSGP,5,PSJJORD)
55 K PSGDRG Q
56PATIENT ; add a patient to Pick List. Can also be called from ^PSGPLUP0.
57 I '$D(^PS(53.5,PSGPLG,1)) S ^(1,0)="^53.51PA^0^0"
58 S $P(^(0),"^",3,4)=PSGP_"^"_($P(^PS(53.5,PSGPLG,1,0),"^",4)+1)
59 ;The naked indicator on the line above references the global reference to the right of the equal sign.
60 S ^PS(53.5,PSGPLG,1,PSGP,0)=PSGP_"^"_TM_"^"_WDN_"^"_RB,^PS(53.5,PSGPLG,1,"B",PSGP,PSGP)=""
61 I $G(PSGAU)=1 S DR=".05////1",DIE="^PS(53.5,"_PSGPLG_",1,",DA(1)=PSGPLG,DA=PSGP D ^DIE K DIE
62 Q
63WS(DND,WD,PSGPLC,PSGDT) ;
64 N AOU,DRUG
65 F F="^PSD(58.8,","^PSI(58.1," I $D(@(F_"""D"","_DND_","_WD_")")) D
66 .F AOU=0:0 S AOU=$O(@(F_"""D"","_DND_","_WD_","_AOU_")")) Q:'AOU!(PSGPLC="WS") D
67 ..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"
68 Q PSGPLC
Note: See TracBrowser for help on using the repository browser.