source: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGPLXR.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: 3.2 KB
Line 
1PSGPLXR ;BIR/MLM-EXECUTE PICK LIST XREFS ;28 FEB 96 / 2:45 PM
2 ;;5.0; INPATIENT MEDICATIONS ;**5,126**;16 DEC 97
3 ;
4EN535(S1,ACT,XREF,FIELD,OLDV) ; Update "AC","AU" x-ref for 53.5 (PICK LIST FILE)
5 S S2=0 D SETVAR F S S2=$O(^PS(53.5,S1,1,S2)) Q:'S2 D EN5351(S1,S2,ACT,XREF,FIELD,OLDV)
6 Q
7 ;
8EN5351(S1,S2,ACT,XREF,FIELD,OLDV) ; Update "AC","AU" x-refs for 53.51 (PATIENT MULTIPLE)
9 N AT,PDD,ND,ON,PD,PL,PT,RB,ST,UP,UP1,WD,X D SETVAR S S3=$O(^PS(53.5,S1,1,S2,1,0))
10 D SET
11 Q:$S('PL:1,AT="":1,WD="":1,RB="":1,PT="":1,1:0)
12 K:$D(^PS(53.5,XREF,PL,AT,WD,RB,PT,"NO ORDERS")) ^("NO ORDERS")
13 I ACT="S",(XREF="AC"!UP1) S ^PS(53.5,XREF,PL,AT,WD,RB,PT,"NO ORDERS")="" Q:'S3
14 S S3=0 F S S3=$O(^PS(53.5,S1,1,S2,1,S3)) Q:'S3 D EN5352(S1,S2,S3,ACT,XREF,FIELD,OLDV)
15 Q
16 ;
17EN5352(S1,S2,S3,ACT,XREF,FIELD,OLDV) ; Update x-refs for 53.52 (ORDER MULTIPLE)
18 N AT,PDD,ND,ON,PD,PL,PT,RB,ST,UP,UP1,WD,X D SETVAR
19 S S4=0,S4=$O(^PS(53.5,S1,1,S2,1,S3,1,S4)) I S4="" D Q
20 .D SET
21 .Q:$S('PL:1,AT="":1,WD="":1,PT="":1,ST="":1,PD="":1,1:0)
22 .K:$D(^PS(53.5,XREF,PL,AT,WD,RB,PT,"NO ORDERS")) ^("NO ORDERS")
23 .K:$D(^PS(53.5,XREF,PL,AT,WD,RB,PT,ST,PD,"NO DISPENSE DRUG")) ^("NO DISPENSE DRUG")
24 .I ACT="S",(XREF="AC"!UP) S ^PS(53.5,XREF,PL,AT,WD,RB,PT,ST,PD,"NO DISPENSE DRUG")="" Q
25 .I XREF="AC"!'UP K:$D(^PS(53.5,XREF,PL,AT,WD,RB,PT,ST,PD)) ^(PD)
26 S S4=0 F S S4=$O(^PS(53.5,S1,1,S2,1,S3,1,S4)) Q:'S4 D EN5353(S1,S2,S3,S4,ACT,XREF,FIELD,OLDV)
27 Q
28 ;
29EN5353(S1,S2,S3,S4,ACT,XREF,FIELD,OLDV) ; Update x-refs for 53.53 (DISPENSE DRUG MULTIPLE)
30 N AT,PDD,ND,ON,PD,PL,PT,RB,ST,UP,UP1,WD,X D SETVAR
31 D SET
32 Q:$S('PL:1,AT="":1,WD="":1,PT="":1,ST="":1,PD="":1,PDD="":1,1:0)
33 K:$D(^PS(53.5,XREF,PL,AT,WD,RB,PT,"NO ORDERS")) ^("NO ORDERS")
34 I $D(^PS(53.5,XREF,PL,AT,WD,RB,PT,ST,PD,"NO DISPENSE DRUG")) K ^("NO DISPENSE DRUG")
35 I ACT="S",(XREF="AC"!UP) S ^PS(53.5,XREF,PL,AT,WD,RB,PT,ST,PD,PDD)="" Q
36 I XREF="AC"!'UP K:$D(^PS(53.5,XREF,PL,AT,WD,RB,PT,ST,PD,PDD)) ^(PDD)
37 Q
38 ;
39SET ; Gather data needed to update "AC","AU" xref
40 S ND=$G(^PS(53.5,+S1,0)),X=$G(^PS(53.5,S1,1,+S2,0)),PL=+ND
41 S AT=$S($L($P(X,U,2)):$P(X,U,2),1:"zz"),WD=$S($P(ND,U,7):"zns",1:$P(X,U,3)),UP1=$P(X,U,5)
42 S X=$P($G(^PS(53.5,S1,1,S2,0)),U,4) I X]"",$P(ND,U,6),X'="zz" S X=$S($P(X,"-",2)?1N:0,1:"")_$P(X,"-",2)_"-"_$P(X,"-")
43 S RB=$S($P(ND,U,8):"zz",X="":"zz",1:X),PT=$E($P($G(^DPT(S2,0)),U),1,12)_U_S2
44 G:'$G(S3) SET2
45 S X=$G(^PS(53.5,S1,1,S2,1,S3,0)),ON=+X,ST=$P(X,U,2),UP=$P(X,U,5),X=$P(X,U,6),PD="" I X S PD=$E($P($G(^PS(50.7,X,0)),U),1,7)_U_S3
46 G:'$G(S4) SET2
47 S X=$G(^PS(53.5,S1,1,S2,1,S3,1,S4,0)),X=+$G(^PS(55,S2,5,ON,1,+X,0)),PDD=$E($P($G(^PSDRUG(+X,0)),U),1,7)_U_S4
48SET2 ; if this is a "kill", see if a field and old value was passed in
49 Q:(XREF'="AC")!(ACT'="K")!(FIELD="")!(OLDV="") Q:(@FIELD="zz")!(@FIELD="zns")
50 S @FIELD=OLDV
51 Q
52SETVAR ;
53 S FIELD=$G(FIELD),OLDV=$G(OLDV)
54 Q
55 ;
56ENABO(S1,XREF,ACT) ;Set AB/AO xref for Pick List, Ward Group, & Start date.
57 N X S X=$G(^PS(53.5,S1,0))
58 I ACT="S" D Q
59 .I (XREF="AB")&('$P(X,"^",5)) S ^PS(53.5,XREF,+$P(X,U,2),+$P(X,U,3),S1)="" Q
60 .I (XREF="AO")&($P(X,"^",5)=2) S ^PS(53.5,XREF,+$P(X,U,2),+$P(X,U,3),S1)=""
61 K ^PS(53.5,XREF,+$P(X,U,2),+$P(X,U,3),S1)
62 Q
63ENA(S1,ACT) ; Set A xref for Pick List # and Ward Group.
64 N X S X=$G(^PS(53.5,S1,0))
65 Q:X=""
66 I ACT="S" S ^PS(53.5,"A",$P(X,U,2),S1)="" Q
67 K ^PS(53.5,"A",$P(X,U,2),S1)
68 Q
Note: See TracBrowser for help on using the repository browser.