source: FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJDOSE.m@ 1754

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

initial load of FOIAVistA 6/30/08 version
File size: 6.1 KB
Line 
1PSJDOSE ;BIR/MV-POSSIBLE DOSES UTILITY ;16 Jan 2001 1:53 PM
2 ;;5.0; INPATIENT MEDICATIONS ;**50,65,106,111**;16 DEC 97
3 ;
4 ; Reference to ^PSSORPH is supported by DBIA #3234.
5 ;
6 ;PSJDSFLG: Set to 1 if Dose and DD are not compatible
7 ;PSJDSSEL: The selected dose in format:
8 ; Dosage Order^DD IEN^DUPD/BCMA DUPD^1(if BCMA DUPD exist
9 ;PSJDSUPD: Set to 1 if need to prompt for the Units Per Dose
10 ;
11EDITDOSE ;Editing Dosage Ordered for active order
12 ;*Need to set PSJDSFLG to null when call EDITDOSE.
13 NEW PSGOER1,PSJDD,PSJDSUPD,PSJDSSEL,PSJX,Y
14 ;Offer the possible doses from the only one or 1st DD
15 S PSJX=$O(^PS(53.45,PSJSYSP,2,0)) S PSJDD=+$G(^(+PSJX,0))
16 D DOSE(PSJDD)
17 D DOSECHK
18 I +PSJDSFLG D
19 . W !!,PSJDOSE("WARN"),!,PSJDOSE("WARN1"),!
20 . D PAUSE^VALM1
21 S PSGOEE=2
22 Q
23GETDOSE(PSJDD) ;Dosage Order
24 NEW PSJDSSEL,PSJDSUPD
25 D DOSE(PSJDD)
26 Q:'$D(PSJDSSEL)
27 D:+$G(PSJDSUPD) DUPD
28 D:'+$G(PSJDSUPD) SETDUPD($P(PSJDSSEL,U,3))
29 D DOSECHK
30 I +$G(PSJDSFLG) D
31 . W !!,PSJDOSE("WARN"),!,PSJDOSE("WARN1"),!
32 Q
33 ;
34SETVAR ;
35 S PSJDOSE("WARN")="WARNING: Dosage Ordered and Dispense Units do not match."
36 S PSJDOSE("WARN1")=" Please verify Dosage."
37 Q
38 ;
39DOSE(PSJDD) ;Prompt for Dosage Ordered
40 ;PSJDD: Dispense drug IEN
41 ;
42 NEW DA,DR,DIR,DTOUT,DUOUT,DIRUT,PSJDL,PSJX,PSJPIECE,PSJCONT
43 D SETVAR
44 D DOSE^PSSORPH(.PSJDOX,+PSJDD,"U")
45 I '$D(PSJDOX) S PSJDOX(1)=-1
46 S PSJPIECE=$S($P(PSJDOX(1),U,11)]"":11,1:3)
47 I PSJPIECE=3 S:$S($P(PSJDOX(1),U,3)="":1,1:$P(PSJDOX(1),U)=-1) $P(PSJDOX(1),U)=-1
48AGAIN ;Prompt for dosage order again
49 S PSJX=0
50 NEW DIR
51 W:($P(PSJDOX(1),U)'=-1) !!,"Available Dosage(s)"
52 F PSJDL=0:0 S PSJDL=$O(PSJDOX(PSJDL)) Q:$S('PSJDL:1,$G(DUOUT):1,1:+PSJDOX(PSJDL)=-1) D
53 . S PSJX=PSJX+1
54 . W !?4,$J(PSJX,3),". ",$P(PSJDOX(PSJDL),U,PSJPIECE)
55 . I '(PSJX#16) S DIR(0)="E" D ^DIR
56 W !
57 K DIR S DIR(0)="FO^1:60"
58 S DIR("A")=$S(+PSJX:"Select from list of Available Dosages or Enter Free Text Dose",1:"DOSAGE ORDERED")
59 S:$G(PSGDO)]"" DIR("B")=PSGDO
60 S DIR("?")="^D ENHLP^PSGOEM(53.1,109)" D ^DIR
61 S PSJY=Y
62 ;
63 ;* Dosage Ordered entered is null
64 I PSJY="" S PSJDSUPD=1,PSGDO="",PSJDSSEL=U_+PSJDD_U_1 Q
65 I $S($D(DTOUT):1,$D(DUOUT):1,$D(DIRUT):1,1:0) S PSGOROE1=1 Q
66 ;
67 ;* If select for the presented list (possible and local doses)
68 I $D(PSJDOX(PSJY)) D G:'PSJCONT AGAIN Q
69 . NEW X S X=$P(PSJDOX(PSJY),U,PSJPIECE)
70 . W " ",X
71 . S PSJCONT=$$CONT(X)
72 . Q:'PSJCONT
73 . D SELDOSE(PSJY,PSJDD)
74 ;
75 ;* Entered a numeric and choices are not local pos dose
76 I PSJY?.N!(PSJY?.N1".".N),(PSJPIECE'=3) D G:'PSJCONT AGAIN Q
77 . Q:$L(PSJY)>15
78 . D DOSE^PSSORPH(.PSJDOX,+PSJDD,"U",,PSJY/+$P(PSJDOX(1),U,5))
79 . S PSJCONT=$$CONT($P(PSJDOX(1),U,11))
80 . I 'PSJCONT D DOSE^PSSORPH(.PSJDOX,+PSJDD,"U") Q
81 . D SELDOSE(1,PSJDD)
82 ;
83 ;* Can't accept just a numeric value
84 I PSJY?.N!(PSJY?.N1".".N) D ENHLP^PSGOEM(53.1,109) G AGAIN
85 ;
86 ;* Free text
87 G:'$$CONT(PSJY) AGAIN
88 K PSJDSSEL
89 F X=0:0 S X=$O(PSJDOX(X)) Q:'X S PSJXDOSE=$P(PSJDOX(X),U,PSJPIECE) I PSJY=PSJXDOSE D SELDOSE(X,PSJDD) Q
90 I '$D(PSJDSSEL),($G(PSJY)]"") S PSJDSSEL=PSJY_U_+PSJDD_U_1,PSGDO=PSJY,PSJDSUPD=1
91 Q
92 ;
93SELDOSE(X,PSJDD) ;
94 S X=PSJDOX(X)
95 S PSGDO=$P(X,U,PSJPIECE)
96 S:$P(X,U)'=-1 PSJDOSE("DO")=$P(X,U,1,2)
97 S PSJDSSEL=$P(X,U,PSJPIECE)_U_PSJDD
98 I +$P(X,U,12) S $P(PSJDSSEL,U,3)=$P(X,U,12)_U_1 Q
99 S $P(PSJDSSEL,U,3)=$S(PSJPIECE=11:$P(X,U,3),1:1)
100 Q
101CONT(X) ;Ask if user accepting the dose
102 NEW DIR,DIRUT,Y
103 W ! K DIR,DIRUT,DUOUT
104 S DIR(0)="Y",DIR("A")="You entered "_X_" is this correct",DIR("B")="Yes"
105 D ^DIR
106 K DUOUT
107 Q +Y
108 ;
109DUPD ;
110 NEW PSJX,X
111 S PSGUD=1
112 W !,"UNITS PER DOSE: "_PSGUD_"// " R X:DTIME W " ",X I X="^"!'$T S PSGOROE1=1 Q
113 S:X="" X=1
114 I X="@",'PSGUD W $C(7)," ??" S X="?" D ENHLP^PSGOEM(53.11,.02) G DUPD
115 I X?1."?" D ENHLP^PSGOEM(53.11,.02) G DUPD
116 I X?1.2N1"/"1.2N S X=+$J(+X/$P(X,"/",2),0,2) W " ("_$E("0",X<1)_X_")"
117 I $S($L(X)>12:1,X'=+X:1,X>50:1,X<0:1,1:X?.N1"."5.N) W $C(7)," ??" S X="?" D ENHLP^PSGOEM(53.11,.02) G DUPD
118 S $P(PSJDSSEL,U,3)=X
119 D SETDUPD(X)
120 Q
121SETDUPD(X) ;
122 S PSGUD=X,X=$S(PSJDSSEL]"":$P(PSJDSSEL,U,2),1:0)
123 S PSJX=$O(^PS(53.45,PSJSYSP,2,"B",X,0))
124 S PSGUD=+$FN(PSGUD,"",4) S:$E(PSGUD)="." PSGUD="0"_PSGUD
125 S $P(^PS(53.45,PSJSYSP,2,+PSJX,0),U,2)=PSGUD
126 Q
127EDITDD ;Editing DDs
128 NEW DA,DR,DIE
129 S DIE="^PS(53.45,",DA=PSJSYSP,DR=2,DR(2,53.4502)=".02//1" D ^DIE
130 I '$O(^PS(53.45,PSJSYSP,2,0)) W $C(7),!!,"WARNING: This order must have at least one dispense drug before pharmacy can",!?9,"verify it!"
131 Q
132DOSECHK ;
133 K PSJDSFLG S PSJDSFLG=0
134 Q:'$P(PSJSYSU,";",4)
135 Q:$G(PSGDO)=""
136 NEW PSJX,PSJXDD,PSJCNT S PSJCNT=0
137 F PSJX=0:0 S PSJX=$O(^PS(53.45,PSJSYSP,2,PSJX)) Q:'PSJX D
138 . S PSJXDD=$G(^PS(53.45,PSJSYSP,2,PSJX,0)) Q:PSJXDD=""
139 . S:$P(PSJXDD,U,2)="" $P(^PS(53.45,PSJSYSP,2,PSJX,0),U,2)=1
140 . S PSJCNT=PSJCNT+1
141 D DOSECHK1
142 Q
143DOSECHK1 ;
144 NEW PSJX,PSJXDD,PSJXUNIT,PSJUNIT,PSJXFLG,PSJTOT
145 S PSJUNIT=$P(PSGDO,+PSGDO,2,$L(PSGDO,+PSGDO))
146 S (PSJDSFLG,PSJXFLG,PSJTOT)=0
147 S PSJX=0 F S PSJX=$O(^PS(53.45,PSJSYSP,2,PSJX)) Q:'PSJX!PSJDSFLG!PSJXFLG D
148 . S PSJXDD=$G(^PS(53.45,PSJSYSP,2,PSJX,0))
149 . S PSJXDUP=$S(+$P(PSJXDD,U,2):$P(PSJXDD,U,2),1:1)
150 . D DOSE^PSSORPH(.PSJXDOX,+PSJXDD,"U")
151 . I $S('$D(PSJXDOX):1,$P(PSJXDOX(1),U)="":1,1:+PSJXDOX(1)=-1) S PSJXFLG=1 Q
152 . S PSJXUNIT=""
153 . S:PSJUNIT["/" PSJXUNIT=PSJUNIT
154 . I PSJUNIT'["/" F X=1:1:$L(PSJUNIT) I $E(PSJUNIT,X)'?.N&($E(PSJUNIT,X)'?1" ") S PSJXUNIT=PSJXUNIT_$E(PSJUNIT,X)
155 . I PSJCNT=1 D ONEDD Q:'PSJDSFLG
156 . D BCMAUPD(PSJXDD),DOSE^PSSORPH(.PSJXDOX,+PSJXDD,"U",,PSJXDUP)
157 . I PSJCNT=1 D ONEDD Q
158 . S PSJTOT=+PSJXDOX(1)+$G(PSJTOT)
159 I PSJCNT>1,(PSJTOT'=+PSGDO) S PSJDSFLG=1
160 Q
161ONEDD ;
162 NEW X S PSJDSFLG=1
163 F X=0:0 S X=$O(PSJXDOX(X)) Q:'X!'PSJDSFLG D
164 . I +PSJXDOX(X)'=+PSGDO,(PSJXUNIT=$P(PSJXDOX(X),U,2)),$S(PSJXDUP=$P(PSJXDOX(X),U,3):1,1:PSJXDUP=$P(PSJXDOX(X),U,12)) D Q:PSJDSFLG
165 .. N CHK S CHK=+PSGDO/$P(PSJXDOX(X),U,5) S CHK=+$FN(CHK,"",4) S:$E(CHK)="." CHK="0"_CHK I CHK=PSJXDUP S PSJDSFLG=0
166 . I +PSJXDOX(X)=+PSGDO,$TR($P(PSJXDOX(X),U,11)," ")=$TR(PSGDO," "),$S(PSJXDUP=$P(PSJXDOX(X),U,3):1,1:PSJXDUP=$P(PSJXDOX(X),U,12)) S PSJDSFLG=0
167 Q
168BCMAUPD(PSJDD) ;
169 NEW PSJCNT
170 K PSJBCMA
171 F X=0:0 S X=$O(PSJXDOX(X)) Q:'X D
172 . Q:'+$P(PSJXDOX(X),U,12)
173 . S PSJCNT=+$G(PSJCNT)+1
174 . S PSJBCMA(+PSJDD,$P(PSJXDOX(X),U,12),PSJCNT)=$P(PSJXDOX(X),U,1,2)
175 Q
176DSPWARN ;
177 NEW PSJDOSE
178 D SETVAR
179 W !!,PSJDOSE("WARN"),!,PSJDOSE("WARN1"),!
180 D PAUSE^VALM1
181 Q
Note: See TracBrowser for help on using the repository browser.