source: FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBO.m@ 636

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

WorldVistAEHR overlayed on FOIAVistA
File size: 8.4 KB
Line 
1PSBO ;BIRMINGHAM/EFC-BCMA OUTPUTS ;Mar 2004
2 ;;3.0;BAR CODE MED ADMIN;**13,32**;Mar 2004;Build 32
3 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
4 ; Reference/IA
5 ; ^DPT(/10035
6 ; WARD^NURSUT5/3052
7 ; EN^PSJBCMA/2828
8 ; ^ORD(101.24/3429
9 ; ^PSDRUG(/221
10RPC(RESULTS,PSBTYPE,PSBDFN,PSBSTRT,PSBSTOP,PSBINCL,PSBDEV,PSBSORT,PSBOI,PSBWLOC,PSBWSORT,PSBFUTR,PSBORDNM,PSBRCRI,PSBLIST) ;
11 ;
12 ; RPC: PSB REPORT
13 ;
14 ; Description:
15 ; Used by the client to create individual patient extracts of
16 ; CHUI report options to display on the client.
17 ;
18 S RESULTS=$NAME(^TMP("PSBO",$J))
19 N PSBIENS,PSBRPT,PSBFDA,DIC,PSBANS
20 K ^TMP("PSBO",$J) S ^TMP("PSBO",$J,1)="-1^"
21 S DFN=PSBDFN
22 D NEW^PSBO1(.PSBRPT,PSBTYPE)
23 I +PSBRPT(0)<1 S ^TMP("PSBO",$J,1)="-1^Error: "_$P(PSBRPT(0),U,2) Q
24 S PSBIENS=+PSBRPT(0)_","
25 S PSBSTRT(0)=$E($P(PSBSTRT,".",2)_"0000",1,4),PSBSTRT=PSBSTRT\1
26 S PSBSTOP(0)=$E($P(PSBSTOP,".",2)_"0000",1,4),PSBSTOP=PSBSTOP\1
27 D:$G(PSBDEV)]""
28 .D NOW^%DTC
29 .I $P(PSBDEV,U,2)="" D VAL^DIE(53.69,PSBIENS,.06,"F",PSBDEV,"PSBRET","PSBFDA")
30 .I $P(PSBDEV,U,2)'="" D VAL^DIE(53.69,PSBIENS,.06,"F","`"_$P(PSBDEV,U,2),"PSBRET","PSBFDA")
31 .D VAL^DIE(53.69,PSBIENS,.07,"F",$S($P(PSBRCRI,U)="QD":$P(PSBRCRI,U,2),1:%),"PSBRET","PSBFDA")
32 D:$G(PSBOI)]"" VAL^DIE(53.69,PSBIENS,.09,"F",PSBOI,"PSBRET","PSBFDA")
33 S:($G(PSBSORT)']"")&(PSBTYPE'="XA") PSBSORT="P" D VAL^DIE(53.69,PSBIENS,.11,"F",PSBSORT,"PSBRET","PSBFDA")
34 D VAL^DIE(53.69,PSBIENS,.12,"F","`"_PSBDFN,"PSBRET","PSBFDA")
35 I $G(PSBWLOC)]"" S PSBFDA(53.69,PSBIENS,.13)=PSBWLOC
36 D:$G(PSBWSORT)]"" VAL^DIE(53.69,PSBIENS,.15,"F",PSBWSORT,"PSBRET","PSBFDA")
37 D VAL^DIE(53.69,PSBIENS,.16,"F",PSBSTRT,"PSBRET","PSBFDA")
38 D VAL^DIE(53.69,PSBIENS,.17,"F",PSBSTRT(0),"PSBRET","PSBFDA")
39 D VAL^DIE(53.69,PSBIENS,.18,"F",PSBSTOP,"PSBRET","PSBFDA")
40 D VAL^DIE(53.69,PSBIENS,.19,"F",PSBSTOP(0),"PSBRET","PSBFDA")
41 D:$G(PSBINCL)]""
42 .D VAL^DIE(53.69,PSBIENS,.21,"F",+$P(PSBINCL,"^",1),"PSBRET","PSBFDA")
43 .D VAL^DIE(53.69,PSBIENS,.22,"F",+$P(PSBINCL,"^",2),"PSBRET","PSBFDA")
44 .D VAL^DIE(53.69,PSBIENS,.23,"F",+$P(PSBINCL,"^",3),"PSBRET","PSBFDA")
45 .D VAL^DIE(53.69,PSBIENS,.24,"F",+$P(PSBINCL,"^",4),"PSBRET","PSBFDA")
46 .D VAL^DIE(53.69,PSBIENS,.28,"F",+$P(PSBINCL,"^",5),"PSBRET","PSBFDA")
47 .D VAL^DIE(53.69,PSBIENS,.29,"F",+$P(PSBINCL,"^",6),"PSBRET","PSBFDA")
48 D:$G(PSBFUTR)]""
49 .D VAL^DIE(53.69,PSBIENS,.25,"F",+$P(PSBFUTR,"^",1),"PSBRET","PSBFDA")
50 .D VAL^DIE(53.69,PSBIENS,.26,"F",+$P(PSBFUTR,"^",2),"PSBRET","PSBFDA")
51 .D VAL^DIE(53.69,PSBIENS,.27,"F",+$P(PSBFUTR,"^",3),"PSBRET","PSBFDA")
52 .D VAL^DIE(53.69,PSBIENS,.41,"F",+$P(PSBFUTR,"^",4),"PSBRET","PSBFDA")
53 .D VAL^DIE(53.69,PSBIENS,.61,"F",$TR(PSBFUTR,"^ ","~"),"PSBRET","PSBFDA")
54 D FILE^DIE("","PSBFDA")
55 I $G(PSBLIST(0),"")]"" D LIST^PSBO1(.PSBLIST)
56 I $G(PSBDEV)]"" D PRINT^PSBO1 S RESULTS=$NAME(^TMP("PSBO",$J)) Q
57 D HFSOPEN^PSBUTL("RPC") I POP S ^TMP("PSBO",$J,1)="ERROR: UNABLE TO ACCESS HFS DIRECTORY "_$$GET^XPAR("DIV","PSB HFS SCRATCH"),^TMP("PSBO",$J,2)="PLEASE CHECK DIRECTORY WRITE PRIVILEDGES." Q
58 U IO D DQ(+PSBIENS)
59 D HFSCLOSE^PSBUTL("RPC")
60 S RESULTS=$NAME(^TMP("PSBO",$J))
61 D:$G(PSBDEV)]"" PRINT^PSBO1
62 Q
63 ;
64XQ(PSBTYPE) ; Called via Kernel Menus
65 N PSBANS,PSBANS1,PSBRPT,PSBSAVE,DA,DIK,DR,DDSFILE
66 D NEW^PSBO1(.PSBRPT,PSBTYPE)
67 I +PSBRPT(0)<1 W !,"Error: ",$P(PSBRPT(0),U,2) S DIR(0)="E" D ^DIR Q
68 S DA=+PSBRPT(0),DR="[PSBO "_PSBTYPE_"]",DDSFILE=53.69 D ^DDS
69 W @IOF
70 I 'PSBSAVE W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!"
71 D:PSBSAVE
72 .;Check Drug to Patient Relationship.
73 .I PSBTYPE="BL" S PSBANS="" D CHECK I PSBANS=0!($D(DIRUT)) W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!" Q
74 .;
75 .;Allow "'BROWSER" Device
76 .S IOP=$$GET1^DIQ(53.69,DA_",",.06,"I"),PSBSIO=0 I IOP]"" D
77 ..S IOP="`"_IOP,%ZIS="N"
78 ..D ^%ZIS
79 ..I IO=IO(0) S PSBSIO=1
80 ..D HOME^%ZIS K IOP
81 .I $$GET1^DIQ(53.69,DA_",",.06)["BROWSER"!(PSBSIO=1) S IOP=$$GET1^DIQ(53.69,DA_",",.06)_";132" D ^%ZIS U IO D DQ(DA) D ^%ZISC K IOP Q
82 .W @IOF,"Submitting Your Report Request to Taskman..."
83 .S ZTIO=$$GET1^DIQ(53.69,DA_",",.06)
84 .S ZTDTH=$P(^PSB(53.69,DA,0),U,7)
85 .S ZTDESC="BCMA - "_$$GET1^DIQ(53.69,DA_",",.05)
86 .S ZTRTN="DQ^PSBO("_DA_")"
87 .D ^%ZTLOAD
88 .W "Submitted!",!,"Your Task Number Is: ",$G(ZTSK),!
89 K ^TMP("PSBO",$J)
90 Q
91 ;
92DQ(PSBRPT) ; Dequeue report from Taskman
93 N PSBWRD,PSBDFN
94 Q:'$D(^PSB(53.69,PSBRPT,0)) ; No Such Report
95 S $P(^PSB(53.69,PSBRPT,0),U,8)=$G(ZTSK,"RPC")
96 D:$$SETUP @("EN^PSBO"_$P(PSBRPT(0),U,5))
97 K ^TMP("PSBO",$J)
98 S ZTREQ="@"
99 Q
100 ;
101IOM() ; Returns good margin or not
102 Q:IOM'<132 1
103 W !,"**************************************************************"
104 W !,"* SORRY, Your selected DEVICE does not print 132 columns. *"
105 W !,"**************************************************************"
106 W !
107 Q 0
108 ;
109VAL(PSBFLDS) ; Validate that fields in PSBFLDS are filled in
110 N PSB,PSBFLD,PSBMSG,PSBSTOP,PSBST,PSBDAYS S PSBSTRT=""
111 F PSB=1:1 Q:$P(PSBFLDS,";",PSB)="" S PSBFLD=$P(PSBFLDS,";",PSB),PSBFLD(PSBFLD)=$$GET^DDSVAL(53.69,DA,PSBFLD)
112 I $D(PSBFLD(.11)) K:$E(PSBFLD(.11))="P" PSBFLD(.13),PSBFLD(.15) K:$E(PSBFLD(.11))="W" PSBFLD(.12)
113 S PSB="" F S PSB=$O(PSBFLD(PSB)) Q:PSB="" D:PSBFLD(PSB)=""
114 .I '$D(PSBMSG) S PSBMSG(0)="UNABLE TO FILE REQUEST",PSBMSG(1)=" ",PSBMSG(2)="ERROR: MISSING DATA - ALL FIELDS ARE REQUIRED",PSBMSG(3)=" "
115 .D FIELD^DID(53.69,PSB,"","TITLE;LABEL","PSB")
116 .S Z=" Missing Field: "_$S(PSB("TITLE")]"":PSB("TITLE"),1:PSB("LABEL"))
117 .S PSBMSG($O(PSBMSG(""),-1)+1)=Z
118 ; Check Times
119 D:$G(PSBFLD(.16))
120 .S PSBSTRT=PSBFLD(.16)+$G(PSBFLD(.17))
121 .D:$P($$GET1^DIQ(53.69,DA_",",.01),U)["MH"
122 ..S PSBDAYS=$$GET1^DIQ(101.24,$$FIND1^DIC(101.24,"","X","ORRP BCMA MAH","B")_",",.42) ;check maxdays
123 ..S:PSBDAYS="" PSBDAYS=7
124 ..S X=PSBSTRT\1 D H^%DTC S PSBST=%H+PSBDAYS ;Determine stop date
125 .S PSBSTOP=$S($G(PSBFLD(.18)):PSBFLD(.18),1:PSBFLD(.16))+$G(PSBFLD(.19))
126 .I PSBSTOP<PSBSTRT S Y=$O(PSBMSG(""),-1)+1,PSBMSG(Y)=" Date: Stop Date/Time is before Start Date/Time"
127 .I $P($$GET1^DIQ(53.69,DA_",",.01),U)["MH" S X=PSBSTOP\1 D H^%DTC I %H>PSBST S Y=$O(PSBMSG(""),-1)+1,PSBMSG(Y)=" The date range cannot exceed "_PSBDAYS_" day(s) as defined in the CPRS 'MAXIMUM DAYS BACK' parameter"
128 Q:'$D(PSBMSG) ; All is well
129 D MSG^DDSUTL(.PSBMSG)
130 S DDSERROR=1
131 Q
132 ;
133SETUP() ; Setup parameters for the report in PSBRPT
134 N PSBWRDL,PSBINDX,PSBWRDA
135 K ^TMP("PSBO",$J)
136 F X=0,.1,.2,.3,.4,1 S PSBRPT(X)=$G(^PSB(53.69,PSBRPT,X))
137 I $D(^PSB(53.69,PSBRPT,2)) M PSBRPT(2)=^PSB(53.69,PSBRPT,2)
138 I $P(PSBRPT(.1),U,1)="P" S PSBDFN=+$P(PSBRPT(.1),U,2) Q:'PSBDFN S ^TMP("PSBO",$J,PSBDFN,0)=$P(^DPT(PSBDFN,0),U)_U_$P(^DPT(PSBDFN,0),U,9),^TMP("PSBO",$J,"B",$P(^DPT(PSBDFN,0),U),PSBDFN)=""
139 D:$P(PSBRPT(.1),U,1)="W"
140 .S PSBWRD=$P(PSBRPT(.1),U,3) Q:'PSBWRD D WARD^NURSUT5("L^"_PSBWRD,.PSBWRDA)
141 .S X="" F S X=$O(PSBWRDA(PSBWRD,2,X)) Q:X="" S PSBWRDL=$P(PSBWRDA(PSBWRD,2,X,.01),U,2) D
142 ..F PSBDFN=0:0 S PSBDFN=$O(^DPT("CN",PSBWRDL,PSBDFN)) Q:'PSBDFN D
143 ...S ^TMP("PSBO",$J,PSBDFN,0)=$P(^DPT(PSBDFN,0),U)_U_$P(^DPT(PSBDFN,0),U,9)
144 ...; Determine Sort or default to Pt Name...
145 ...S:$P(PSBRPT(.1),U,5)="P" PSBINDX=$P(^DPT(PSBDFN,0),U)
146 ...I $P(PSBRPT(.1),U,5)="B" S PSBINDX=$P($G(^DPT(PSBDFN,.101)),U) S:PSBINDX="" PSBINDX="** NO ROOM BED **"
147 ...S:$P(PSBRPT(.1),U,5)="" PSBINDX=$P(^DPT(PSBDFN,0),U)
148 ...S:$G(PSBINDX)="" PSBINDX=$P(^DPT(PSBDFN,0),U)
149 ...S ^TMP("PSBO",$J,"B",PSBINDX,PSBDFN)=""
150 Q 1
151 ;
152WRAP(X,Y,Z) ; Quick text wrap
153 ;
154 ; Input Parameters Description:
155 ; X: Left Column of display [Optional]
156 ; Y: Cols to wrap in [Optional]
157 ; Z: Text to wrap [Optional]
158 ;
159 N PSB
160 F Q:'$L(Z) D
161 .W:$X>X !
162 .W:$X<X ?X
163 .I $L(Z)<Y W Z S Z="" Q
164 .F PSB=Y:-1:0 Q:$E(Z,PSB)=" "
165 .S:PSB<1 PSB=Y
166 .W $E(Z,1,PSB)
167 .S Z=$E(Z,PSB+1,250)
168 Q ""
169 ;
170CHECK ;Beginning of PSB*1*10
171 K ^TMP("PSJ",$J)
172 N PSBDFN,PSBBAR,PSBDRUG,PSBFLAG,PSBPNM,PSBNDX,PSBX
173 S PSBFLAG="",PSBBAR=$P($P($G(^PSB(53.69,DA,.3)),U,1),"~",2)
174 S PSBDRUG=$$GET1^DIQ(53.69,DA_",",.31)
175 S PSBDFN=$$GET1^DIQ(53.69,DA_",",.12,"I") S:$G(PSBDFN) PSBFLAG=1
176 D EN^PSJBCMA(PSBDFN)
177 F PSBX=0:0 S PSBX=$O(^TMP("PSJ",$J,PSBX)) Q:'PSBX D
178 .K Y,PSBORD,PSBPNM,PSBNDX
179 .M PSBORD=^TMP("PSJ",$J,PSBX)
180 .F PSBNDX=700,850,950 D
181 ..F Y=0:0 S Y=$O(PSBORD(PSBNDX,Y)) Q:'Y D
182 ...I $P($G(PSBORD(1)),U,7)'="A" Q
183 ...S PSBPNM=$P(PSBORD(PSBNDX,Y,0),U,1)
184 ...I PSBNDX=700,PSBPNM=PSBBAR S PSBFLAG=0 Q
185 ...I PSBNDX=850,$D(^PSDRUG("A526",PSBBAR,PSBPNM)) S PSBFLAG=0 Q
186 ...I PSBNDX=950,$D(^PSDRUG("A527",PSBBAR,PSBPNM)) S PSBFLAG=0
187 I PSBFLAG=1 D
188 .W !,"Patient is not currently on medication: ",PSBDRUG
189 .K DIRUT,DIR
190 .S DIR("A")="Do you want to continue"
191 .S DIR(0)="Y"
192 .D ^DIR
193 .S PSBANS=+Y W !
194 ;
Note: See TracBrowser for help on using the repository browser.