source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBML.m@ 1688

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

initial load of FOIAVistA 6/30/08 version
File size: 9.4 KB
Line 
1PSBML ;BIRMINGHAM/EFC-BCMA MED LOG FUNCTIONS ;Mar 2004
2 ;;3.0;BAR CODE MED ADMIN;**6,3,4,9,11,13**;Mar 2004
3 ;
4 ; Reference/IA
5 ; ^DPT/10035
6 ; DIC(42/10039
7 ; DIC(42/2440
8 ; File 200/10060
9 ; EN^PSJBCMA3/3320
10 ; $$SITE^VASITE/10112
11 ; ^XUSEC(/10076
12 ;
13RPC(RESULTS,PSBHDR,PSBREC) ;BCMA MedLog Filing
14 S PSBEDTFL=0
15 N PSBORD,PSBTRAN,PSBFDA
16 K PSBIEN,PSBHL7
17 S PSBIEN=$P(PSBHDR,U,1)
18 S PSBTRAN=$P(PSBHDR,U,2),PSBHL7=PSBTRAN
19 S PSBINST=$P($G(PSBHDR),U,3)
20 S PSBAUDIT=$S(PSBIEN="+1":0,1:1)
21 D NOW^%DTC S PSBNOW=%
22 I $D(^XUSEC("PSB STUDENT",DUZ)),PSBINST="" S RESULTS(0)=1,RESULTS(1)="-1^Instructor not present" Q
23 I $D(^XUSEC("PSB STUDENT",DUZ)),'$D(^XUSEC("PSB INSTRUCTOR",PSBINST)) S RESULTS(0)=1,RESULTS(1)="-1^Instructor doesn't have authority" Q
24 S PSBINST(0)=$$GET1^DIQ(200,PSBINST_",",.01)
25 I PSBTRAN="ADD COMMENT" D COMMENT^PSBML1 Q
26 I PSBTRAN="PRN EFFECTIVENESS" D PRN^PSBML1 Q
27 I PSBTRAN="UPDATE STATUS" D Q
28 .I '$D(^PSB(53.79,PSBIEN)) S RESULTS(0)=1,RESULTS(1)="-1^Administration is at an UNKNOWN STATUS" Q
29 .D UPDATED^PSBML2
30 I PSBTRAN="EDIT" D EDIT^PSBML2 Q
31 ;SAGG
32 N PSBWARD S PSBWARD=$G(^DPT(+$G(PSBREC(0)),.1),"UNKNOWN"),^PSB("SAGG",PSBWARD,DT)=$G(^PSB("SAGG",PSBWARD,DT))+1
33 I PSBREC(1)?1U1";"1.6N S PSBREC(1)=$P(PSBREC(1),";",1)_$E(PSBREC(1))
34 D PSJ1^PSBVT(PSBREC(0),$P(PSBREC(1),";",2)_$P(PSBREC(1),";",1))
35 S PSBTAB=$P(PSBREC(9),U,1),PSBUID=$P(PSBREC(9),U,2)
36 D:PSBTRAN="MEDPASS"
37 .I (PSBDOSEF["PATCH"),(PSBREC(3)="G") D Q:+$G(RESULTS(1))<0
38 ..S PSBXDT="" F S PSBXDT=$O(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBXDT)) Q:PSBXDT="" D Q:+$G(RESULTS(1))<0
39 ...S PSBYZ="" F S PSBYZ=$O(^PSB(53.79,"AORDX",PSBDFN,PSBONX,PSBXDT,PSBYZ)) Q:'PSBYZ I ("G"[$$GET1^DIQ(53.79,PSBYZ,.09,"I")) D Q
40 ....S:($$GET1^DIQ(53.79,PSBYZ,.09,"I")="G") RESULTS(0)=1,RESULTS(1)="-1^Previous Patch has not been removed. Administration canceled."
41 ....S:($$GET1^DIQ(53.79,PSBYZ,.09,"I")="")&(($$GET1^DIQ(53.79,PSBYZ,.07,"I")'=DUZ)&('$D(^XUSEC("PSB MANAGER",DUZ)))) RESULTS(0)=1,RESULTS(1)="-1^Patch status ""*UNKNOWN*"". Administration canceled."
42 .I PSBREC(7)="BCMA/CPRS Interface Entry." S PSBNOW=PSBREC(5) ;MOB
43 .F X=0:1:9 S PSBREC(X)=$G(PSBREC(X))
44 .I PSBREC(1)?1U1";".N S PSBREC(1)=$P(PSBREC(1),";",2)_$P(PSBREC(1),";",1)
45 .I PSBREC(1)["V",+PSBREC(5)>0,+$P(PSBREC(5),".",2)=0,PSBIVT'["P" D NOW^%DTC S PSBREC(5)=$P(PSBREC(5),".",1)_"."_$P(%,".",2)
46 .I $P(PSBREC(9),U,1)="IVTAB",$P(PSBREC(9),U,2)="" S PSBUID=$$GETWSID^PSBVDLU2(PSBREC(0),PSBREC(1))
47 .I $P(PSBREC(9),U,1)="PBTAB",$P(PSBREC(9),U,2)="",PSBREC(1)'["U",PSBREC(3)'="M",PSBREC(3)'="R",PSBREC(3)'="H" S PSBUID=$$GETWSID^PSBVDLU2(PSBREC(0),PSBREC(1))
48 .;OnCal
49 .D:PSBREC(2)="OC"
50 ..S X=$O(^PSB(53.79,"AORD",PSBREC(0),PSBREC(1),"")) Q:X=""
51 ..S Y=$O(^PSB(53.79,"AORD",PSBREC(0),PSBREC(1),X,0))
52 ..I $P(^PSB(53.79,Y,0),U,9)="G"&('$$GET^XPAR("DIV","PSB ADMIN MULTIPLE ONCALL")) D ERR(1,"On-Call already given")
53 .;1x
54 .D:PSBREC(2)="O"
55 ..S X=$O(^PSB(53.79,"AORD",PSBREC(0),PSBREC(1),"")) Q:X=""
56 ..S Y=$O(^PSB(53.79,"AORD",PSBREC(0),PSBREC(1),X,0))
57 ..I $P(^PSB(53.79,Y,0),U,9)="G" D ERR(1,"One Time already Given")
58 .;PRN
59 .I PSBREC(2)="P",PSBREC(3)'="M",$P(PSBREC(9),U,1)'="IVTAB" D
60 ..I PSBREC(6)="" D ERR(1,"PRN Medications MUST Have a PRN Reason")
61 ..I PSBREC(5)]"" D ERR(1,"PRN Orders don't have scheduled times")
62 ..I PSBREC(3)'="G" D ERR(1,"PRN Orders cannot be marked NOT Given")
63 .;Cnt
64 .I PSBREC(2)="C",PSBTAB'="IVTAB" D
65 ..D:PSBREC(5)="" ERR(1,"Continuous Order needs admin time")
66 ..D:PSBREC(6)]"" ERR(1,"No PRN Reason allowed on Continuous Orders")
67 .I PSBREC(2)="C",$D(^PSB(53.79,"AORD",PSBREC(0),PSBREC(1),+PSBREC(5))),PSBIEN="+1" D K PSBADMBY,PSBADMAT Q:PSBSIEN="" Q:$P(^PSB(53.79,PSBSIEN,0),U,9)'="N"
68 ..S PSBSIEN=$O(^PSB(53.79,"AORD",PSBREC(0),PSBREC(1),PSBREC(5),""))
69 ..I PSBSIEN]"" I '(($P(^PSB(53.79,PSBSIEN,0),U,7)=DUZ)!($D(^XUSEC("PSB MANAGER",DUZ)))) S PSBSIEN=""
70 ..I PSBSIEN']"" S RESULTS(0)=2,RESULTS(1)="-2^Error Filing Transaction MEDPASS",RESULTS(2)="This scheduled admin is being modified by another." Q
71 ..D:$P(^PSB(53.79,PSBSIEN,0),U,9)'="N"
72 ...K PSBINCX I $P(^PSB(53.79,PSBSIEN,0),U,9)="" S PSBINCX=PSBSIEN L +^PSB(53.79,PSBINCX):1 Q:'$T L -^PSB(53.79,PSBINCX)
73 ...S Y=$P(^PSB(53.79,PSBSIEN,0),U,6) D DD^%DT S PSBADMAT=Y
74 ...S PSBADMBY=$$GET1^DIQ(200,$P(^PSB(53.79,PSBSIEN,0),U,7),.01,)
75 ...S RESULTS(0)=3,RESULTS(1)="-2^Error Filing Transaction MEDPASS"
76 ...S RESULTS(2)="Continuous Administration Date/Time already on file."
77 ...S RESULTS(3)="Administered by "_PSBADMBY_" at "_PSBADMAT_"."
78 ...I $D(XWB) S RESULTS(0)=RESULTS(0)+2,RESULTS(4)=" ",RESULTS(5)=" VDL will now be updated."
79 .;NonGvn
80 .I PSBREC(3)'="G",PSBREC(3)'="M",PSBUID'["V",PSBUID'["W" D
81 ..I PSBREC(7)="",PSBTAB'="IVTAB" D ERR(1,"Comment needed if Not Marked Given")
82 ..I PSBREC(7)="",PSBTAB="IVTAB" D ERR(1,"Comment needed if Not Marked Completed")
83 .S:PSBREC(3)="H" PSBREC(7)="Held: "_PSBREC(7) ;.3
84 .S:PSBREC(3)="R" PSBREC(7)="Refused: "_PSBREC(7) ;.3
85 .S:PSBREC(3)="S" PSBREC(7)="Stopped: "_PSBREC(7) ;.3
86 .;Vald?
87 .I $G(PSBSIEN)'="" I $D(^PSB(53.79,PSBSIEN,0)) I $P(^PSB(53.79,PSBSIEN,0),U,9)="N" S PSBIEN=+PSBSIEN_",",$P(PSBHDR,U)=PSBIEN,PSBTRAN="UPDATE STATUS",PSBAUDIT=1 ;do UPDATE
88 .D:PSBIEN="+1" ;New?
89 ..D VAL(53.79,PSBIEN,.01,"`"_PSBREC(0)) ;Pt
90 ..S X=$G(^DPT(PSBREC(0),.1))_" "_$G(^(.101)) ;WrdRmBd
91 ..D VAL(53.79,PSBIEN,.02,X) ;PtLoc
92 ..D:$G(^DPT(PSBREC(0),.1))'=""
93 ...S Y=$O(^DIC(42,"B",$G(^DPT(PSBREC(0),.1)),"")),Y=$$GET1^DIQ(42,Y,.015,"I"),PSBDIV=$$SITE^VASITE(DT,Y)
94 ...D VAL(53.79,PSBIEN,.03,"`"_$P(PSBDIV,U,1)) ;Div
95 ..D VAL(53.79,PSBIEN,.04,PSBNOW) ;EntDT
96 ..D VAL(53.79,PSBIEN,.05,"`"_DUZ) ;Who
97 ..D VAL(53.79,PSBIEN,.06,PSBNOW) ;AdmDT
98 ..D VAL(53.79,PSBIEN,.07,"`"_DUZ) ;AdmBy
99 ..D VAL(53.79,PSBIEN,.08,"`"_PSBREC(4)) ;OrdblItm
100 ..D VAL(53.79,PSBIEN,.11,PSBREC(1)) ;OrdTpeIEN
101 ..D VAL(53.79,PSBIEN,.12,PSBREC(2)) ;OrdSchdTpe
102 ..D VAL(53.79,PSBIEN,.13,PSBREC(5)) ;SchdAdmDT
103 ..D:PSBTAB'="UDTAB" VAL(53.79,PSBIEN,.26,PSBUID) ;Bag
104 ..D:PSBTAB="IVTAB" VAL(53.79,PSBIEN,.13,"") ;no SchdAdm - lvIV
105 ..D:PSBREC(1)?.N1"U" VAL(53.79,PSBIEN,.15,PSBDOSE) ;UDDsage
106 ..D:PSBREC(1)?.N1"V" VAL(53.79,PSBIEN,.35,PSBIFR) ;IVInfRt
107 .;Ovrwrt if exsts
108 .I PSBREC(3)="G"!(PSBREC(3))="C" D ;Gvn/Cmpltd?
109 ..D VAL(53.79,PSBIEN,.06,PSBNOW) ;AdmDT
110 ..D VAL(53.79,PSBIEN,.07,"`"_DUZ) ;AdmBy
111 .D:PSBREC(8)]"" VAL(53.79,PSBIEN,.16,PSBREC(8)) ;InjctSte
112 .D:'$G(PSBMMEN) VAL(53.79,PSBIEN,.09,PSBREC(3)) ;AStats
113 .D:PSBREC(6)]"" VAL(53.79,PSBIEN,.21,$P(PSBREC(6),U)),VAL(53.79,PSBIEN,.27,$P(PSBREC(6),U,2)) ;PRNRsn
114 .D:PSBREC(7)]""
115 ..D VAL(53.793,"+2,"_PSBIEN,.01,PSBREC(7)) ;Cmnt
116 ..D VAL(53.793,"+2,"_PSBIEN,.02,"`"_DUZ) ;Who
117 ..D VAL(53.793,"+2,"_PSBIEN,.03,PSBNOW)
118 .;DD/SOL/ADD
119 .I PSBREC(3)="G"!(PSBREC(3)="I")!(PSBREC(3)="H")!(PSBREC(3)="R")!(PSBREC(3)="M") D ;gvn/infs?
120 ..I PSBTRAN="UPDATE STATUS" K ^PSB(53.79,+PSBIEN,.5),^PSB(53.79,+PSBIEN,.6),^PSB(53.79,+PSBIEN,.7)
121 ..F PSBCNT=10:1 Q:'$D(PSBREC(PSBCNT)) D
122 ...S Y=$P(PSBREC(PSBCNT),U)
123 ...S PSBDD=$S(Y="DD":53.795,Y="ADD":53.796,Y="SOL":53.797,1:0)
124 ...Q:'PSBDD
125 ...S PSBIENS="+"_PSBCNT_","_PSBIEN
126 ...D VAL(PSBDD,PSBIENS,.01,"`"_$P(PSBREC(PSBCNT),U,2))
127 ...D VAL(PSBDD,PSBIENS,.02,$P(PSBREC(PSBCNT),U,3))
128 ...D VAL(PSBDD,PSBIENS,.03,$P(PSBREC(PSBCNT),U,4))
129 ...D:(PSBTAB="UDTAB")!(PSBTAB="PBTAB") VAL(PSBDD,PSBIENS,.04,$E($P(PSBREC(PSBCNT),U,5),1,20))
130 .I $O(RESULTS("")) S RESULTS(0)=1,RESULTS(1)="-1^Error(s) Filing Transaction MEDPASS" Q
131 .D FILEIT
132 .D:(PSBREC(2)="O")&(PSBREC(3)="G") EXPIRE^PSBML1 ;1x exp?
133 .I $P(RESULTS(0),U,1)=1,PSBTAB'="UDTAB",PSBUID]"",PSBUID'["WS" S PSBON=+PSBREC(1) D EN^PSJBCMA3(PSBREC(0),PSBON,PSBUID,PSBREC(3),PSBNOW)
134 Q
135BCBU ;HL7,NatContng
136 Q:+$G(RESULTS(0))'>0
137 N PSBIEN1 S PSBIEN1=$S($P(PSBIEN,",",2)'="":+$P(PSBIEN,",",2),$G(PSBIEN)="+1":PSBIEN(1),1:+$G(PSBIEN))
138 I $G(PSBIEN1)="" S RESULTS(0)=1,RESULTS(1)="-1^Contingency NOT processed" Q
139 I $G(PSBIEN)="+1" S PSBHL7="MEDPASS"
140 E S:$G(PSBHL7)="" PSBHL7="UPDATE STATUS"
141 D:('$D(Y(0))!($G(Y(0))="SAVE")!($G(Y(0))="YES")) EN^PSBSVHL7(+PSBIEN1,PSBHL7),MEDL^ALPBCBU(+PSBIEN1) K PSBHL7
142 ;<<HDR-VDEF(frm *3)
143 Q
144VAL(PSBDD,PSBIEN,PSBFLD,PSBVAL) ;
145 K ^TMP("DIERR",$J),PSBRET
146 D VAL^DIE(PSBDD,PSBIEN,PSBFLD,"F",PSBVAL,.PSBRET,"PSBFDA")
147 I PSBRET="^" F X=0:0 S X=$O(^TMP("DIERR",$J,X)) Q:'X D ERR(2,^TMP("DIERR",$J,X)_": "_$G(^(X,"TEXT",1),"**"))
148 K ^TMP("DIERR",$J),PSBRET
149 Q
150FILEIT ;Updt
151 N PSBMSG,PSBAUD
152 S (PSB1,PSB2)=""
153 D APATCH^PSBML3
154 D CLEAN^DILF
155 D RESETADM^PSBUTL
156 D UPDATE^DIE("","PSBFDA","PSBIEN","PSBMSG")
157 I '$G(PSBMMEN) S X=+PSBIEN I $F("HR",$P(^PSB(53.79,X,0),U,9))>1 F Y=.5,.6,.7 S Z=0 F S Z=$O(^PSB(53.79,+X,Y,Z)) Q:+Z=0 S $P(^PSB(53.79,+X,Y,Z,0),U,3)=0
158 I $D(PSBMSG("DIERR")) S RESULTS(0)=1,RESULTS(1)="-1^"_PSBMSG("DIERR",1)_": "_PSBMSG("DIERR",1,"TEXT",1) Q
159 I $G(PSB1)]"" X PSB1 I $G(PSB2)]"" X PSB2
160 I $D(PSBHDR) D:"NHMR"[$P(^PSB(53.79,$S($P(PSBHDR,"^",1)="+1":PSBIEN(1),1:+PSBIEN),0),U,9)
161 .N PSBINDX S PSBINDX=$S($P(PSBHDR,"^",1)="+1":PSBIEN(1),1:+PSBIEN)
162 .K ^PSB(53.79,"APATCH",$P(^PSB(53.79,PSBINDX,0),U),$P(^PSB(53.79,PSBINDX,0),U,6),PSBINDX)
163 S RESULTS(0)=1,RESULTS(1)="1^Data Successfully Filed^"_$S($G(PSBIEN(1))'="":$G(PSBIEN(1)),1:+$G(PSBIEN))
164 D BCBU ;NatContng
165 I $G(PSBINST,0) S PSBAUD=$S($P(PSBHDR,"^",1)="+1":PSBIEN(1),1:$P(PSBHDR,"^",1)) D AUDIT^PSBMLU(PSBAUD,"Instructor "_PSBINST(0)_" present.",PSBTRAN)
166 Q
167ERR(X,Y) ;
168 S X=$P("Business Logic Error^Data Validation Error",U,X)
169 S RESULTS($O(RESULTS(""),-1)+1)=X_": "_Y
170 Q
171COMMENT(DA,PSBCMT) ;
172 N PSBFDA,PSBIEN,PSBNOW
173 S PSBIEN="+1,"_DA_","
174 D NOW^%DTC S PSBNOW=%
175 D VAL(53.793,PSBIEN,.01,PSBCMT)
176 S PSBFDA(53.793,PSBIEN,.02)=DUZ
177 S PSBFDA(53.793,PSBIEN,.03)=PSBNOW
178 D FILEIT
179 Q
Note: See TracBrowser for help on using the repository browser.