source: FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGPLUP0.m@ 767

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

initial load of FOIAVistA 6/30/08 version
File size: 5.1 KB
Line 
1PSGPLUP0 ;BIR/CML3-UPDATING FOR PSGPLUP OCCURS HERE ;06 AUG 96 / 10:53 PM
2 ;;5.0; INPATIENT MEDICATIONS ;**50,129**;16 DEC 97
3 ;
4 ; Reference to ^PS(55 is supported by DBIA #2191.
5 ; Reference to ^PS(59.7 is supported by DBIA #2181
6 ; Reference to ^DIC(42 is supported by DBIA #1377.
7 ; Reference to ^DPT( is supported by DBIA #10035.
8 ;
9ENQ ; check for a previous update, if there is one "unflag" updated orders.
10 ;
11 I '$$LOCK^PSGPLUTL(PSGPLG,"PSGPL") H 60 G ENQ
12 D NOW^%DTC S PSJACNWP=1,PSGAU="",PSGDT=%,(PDRG,PN,PST,RB,TM,WDN)="",EST=$S($P(PSGPLTND,"^",13):"A",1:"Z"),PSJACNWP=1
13 F S PSGX=$Q(^PS(53.5,"AU",PSGPLG)),PSGXP=$P(PSGX,"53.5",2) Q:$P(PSGXP,",",2,3)'=("""AU"","_PSGPLG) D UNFLAG
14 K PSGP,PSGORD,I,X,PSGX,PSGXP
15 ;
16 ; check each patient in the ward group
17 ;
18 S X1=$P(PSGPLS,"."),X2=-1 D C^%DTC S PSGPLUPO=X_(PSGPLS#1)
19 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
20 ;
21 ; 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)
22 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
23 F S PSGX=$Q(@PSGX) Q:$P(PSGX,",",2,3)'=("""AC"","_PSGPLG) S PSGP=+$P(PSGX,"^",3) D:$D(^PS(55,"AUE",PSGP)) UP
24 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
25 D NOW^%DTC S $P(^PS(53.5,PSGPLG,0),"^",10)=%
26 ;
27DONE ;
28 D UNLOCK^PSGPLUTL(PSGPLG,"PSGPL") K %,%X,%Y,DA,DIK,DRG,EST,NST,PSJJORD,PN,PSGPLO,PSGAU,PSGNDATE,PSGPLS,PSGPLUPO,PSGPLWD
29 K PSGPLWDN,PSGX,PSGXP,PST,PSGUP,PSGORD,PSJACNWP,RB,SD,TM,X,X1,X2 Q
30 ;
31UP ; if patient has an update (AUE xref on UD subfile), add order and drug multiples to Pick List and flag as updated.
32 ; if patient not on last pick list (i.e., transferred or admitted
33 ; and has no orders, add to Pick List patient multiple and flag as updated (do PATIENT^PSGPL1).
34 D ^PSJAC,ENUNM^PSGOU
35 S DFN=PSGP,WD=0,WDN=$G(^DPT(PSGP,.1)),RB=$G(^DPT(PSGP,.101)) S:WDN]"" WD=+$O(^DIC(42,"B",WDN,0))
36 S TM=$S(RB="":"",1:$P($G(^PS(57.7,WD,1,+$O(^PS(57.7,"AWRT",WD,RB,0)),0)),"^"))
37 F X="RB","TM","WDN" S:@X="" @X="zz"
38 ; 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
39 ; Determine if patient is on the same or different ward group
40 ; (GRP=1:Same,GRP=0:Different)
41 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)
42 S PN=$P(PSGP(0),"^"),PN=$S(PN]"":$E(PN,1,12),1:PSGP)_"^"_PSGP
43 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
44 I GRP,'$G(^PS(53.5,PSGPLG,1,PSGP,0)) S PSGAU=1 D PATIENT^PSGPL1
45 ;
46 ;Update orders already on PL for this patient.
47 N PSJSITE,PSJPRN S PSJSITE=0,PSJSITE=$O(^PS(59.7,PSJSITE)) I $P($G(^(PSJSITE,26)),U,5)=1 S PSJPRN=1
48 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
49 ;
50 ;If patient is on a different WG update only DE orders.
51 I 'GRP D NOW^%DTC S PSGDT=%,X1=$P(PSGPLS,"."),X2=-1 D C^%DTC S PSGPLD=X_(PSGPLS#1) D
52 .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
53 ..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
54 Q
55 ;
56UP1 ;
57 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
58 Q
59 ;
60ENASET ;
61 ; if you're adding an order that is already on the PL, delete the old one first
62 I $D(^PS(53.5,PSGPLG,1,PSGP,1,"B",PSJJORD)) D D ^DIK K DIK
63 .N PSGOST S PSGOST=$P($$LASTREN^PSJLMPRI(PSGP,PSJJORD_"U"),"^",4) I PSGOST D
64 ..N PSGPLS,PSGPLF S PSGPLS=$P(PSGPLTND,"^",3),PSGPLF=$P(PSGPLTND,"^",4) I PSGOST>PSGPLS&(PSGOST<PSGPLF) D
65 ...N PSGPLO S PSGPLO=$O(^PS(53.5,PSGPLG,1,PSGP,1,"B",PSJJORD,999),-1)
66 ...M PSGPLREN(53.5,PSGPLG,1,PSGP,1,PSGPLO)=^PS(53.5,PSGPLG,1,PSGP,1,PSGPLO) S PSGPLREN("B",PSGP,PSJJORD,PSGPLO)=PSGOST
67 ...N PSGPLX F PSGPLX="AC","AU" M PSGPLREN(53.5,PSGPLX,PSGPLG)=^PS(53.5,PSGPLX,PSGPLG)
68 .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,"
69 .S:$D(^PS(53.5,DA(2),1,DA(1),0)) $P(^(0),U,5)=""
70 .S:$D(^PS(53.5,DA(2),1,DA(1),1,DA,0)) $P(^(0),U,5)=""
71 ; go to ^PSGPL1 to add new orders to the PL. (unless the patient has no ward, in which case he's probably discharged)
72 N PSGPLWD S PSGPLWD=WD
73 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
74 Q
75UNFLAG ; unset "old" update flag
76 ;
77 S PSGP=+$P(PSGX,"^",3),PSGORD=+$P(PSGX,"^",4)
78 S $P(^PS(53.5,PSGPLG,1,PSGP,0),"^",5)="" K @PSGX
79 S:PSGORD $P(^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,0),"^",5)=""
80 Q
Note: See TracBrowser for help on using the repository browser.