source: FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL10.m@ 1288

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

initial load of FOIAVistA 6/30/08 version
File size: 9.4 KB
Line 
1PSJHL10 ;BIR/LDT,BSJ-VALIDATE INCOMING HL7 DATA/CREATE NEW ORDER ;30 MAY 07
2 ;;5.0; INPATIENT MEDICATIONS ;**58,78,91,109,110,195**;16 DEC 97;Build 3
3 ;
4 ; Reference to ^PSDRUG is supported by DBIA# 2192.
5 ; Reference to ^PS(51.2 is supported by DBIA# 2178.
6 ; Reference to ^PS(55 is supported by DBIA# 2191.
7 ; Reference to ^PS(52.6 is supported by DBIA# 1231.
8 ; Reference to ^PS(52.7 is supported by DBIA# 2173.
9 ; Reference to ^PSBAPIPM is supported by DBIA# 3564.
10 ; Reference to ^ORERR is supported by DBIA# 2187.
11 ;
12VALID ;
13 ;Call BCMA for rest of data
14 D MOB^PSBAPIPM(PSJHLDFN,+PSJORDER)
15 N DATA0,CHK S DATA0=$G(^TMP("PSB",$J,0)) I DATA0=-1 S PSREASON="""YOUR ORDER WAS NOT SAVED. EXIT BCMA, SIGN BACK IN, THEN TRY AGAIN.""" D ERROR Q
16 I $P(DATA0,"^")'=PSJHLDFN S PSREASON="Patient does not match" D ERROR Q
17 I $P(DATA0,"^",2)'=+PSJORDER S PSREASON="Order number does not match" D ERROR Q
18 N VAIP S DFN=PSJHLDFN,VAIP("D")=$G(LOGIN) D IN5^VADPT
19 ;If UD do UD set/validate.
20 I $P(DATA0,"^",3)="" D UDSET
21 ;If IV do IV set/validate.
22 I $P(DATA0,"^",3)]"" D IVSET
23 D:'CHK EN1^PSJHL2(PSJHLDFN,"OK",PSGORD),EN1^PSJHL2(PSJHLDFN,"SC",PSGORD),EN1^PSJHL2(PSJHLDFN,"ZV",PSGORD),MOBR^PSBAPIPM(PSJHLDFN,+PSJORDER,PSGORD)
24 Q
25 ;
26ERROR ;Sends error msg to CPRS, logs error in OE/RR Errors file
27 S X="ORERR" X ^%ZOSF("TEST") I D EN^ORERR(PSREASON,.PSJMSG),MOBR^PSBAPIPM(PSJHLDFN,+PSJORDER)
28 D EN1^PSJHLERR(PSJHLDFN,"OC",PSJORDER,PSREASON) S QFLG=1 K ^TMP("PSJNVO",$J),^TMP("PSB",$J)
29 Q
30 ;
31UDSET ;Set up UD variables
32 N PSGPR,PSGMR,PSGSM,PSGHSM,PSGST,PSGP,PSGSCH,PSGPDRG,PSGDO,PSGNESD,PSGNEFD,PSGOEAV,PSJSYSU,PSGS0XT,PSGS0Y
33 S PSGPR=PROVIDER,PSGMR=ROUTE,PSGSM=0,PSGHSM="",PSGST="O",PSGP=PSJHLDFN,PSGSCH=SCHEDULE,PSGPDRG=PSITEM
34 S (PSGNESD,PSGNEFD)=+$P(DATA0,"^",5),PSGOEAV=1,PSJSYSU=1,PSGS0XT="O",PSGS0Y=""
35 I $G(DOSE)]"",$G(UNIT)]"" S PSGDO=DOSE_UNIT
36 I $G(PSGDO)']"",$G(INSTR)]"" S PSGDO=$$TRIM^XLFSTR(INSTR,"R"," ")
37 S CHK=""
38 S ND=U_PSGPR_U_PSGMR_"^U^"_PSGSM_U_PSGHSM_U_PSGST_"^^"_"E"_"^^^^^"_LOGIN_U_PSGP_U_LOGIN
39 D CHK("^^"_PSGMR_"^^^^"_PSGST,PSGPDRG_U_PSGDO,PSGSCH_U_PSGNESD_"^^"_PSGNEFD)
40 I CHK D ERROR Q
41 I PSGSCH'="STAT",PSGSCH'="NOW" S PSREASON="Invalid Schedule" S CHK=1 D ERROR Q
42 I ORDCON'="V",ORDCON'="P" S PSREASON="Invalid Nature of Order" S CHK=1 D ERROR Q
43 D:'$D(^PS(55,PSGP,0)) ENSET0^PSGNE3(PSGP) S $P(^PS(55,PSGP,5.1),U,2)=PSGPR,PSGOEPR=PSGPR
44 S ND0=ND D ENGNA^PSGOETO
45 I $D(^PS(51.2,+PSGMR,0)),$P(^(0),U,3)]"" S PSGMRN=$P(^(0),U,3)
46 S ND0=DA_ND0
47 S $P(ND0,"^",21)=PSJORDER
48 S ND2=PSGSCH_U_PSGNESD_"^^"_PSGNEFD_U_PSGS0Y_U_PSGS0XT_"^^^^"_+VAIP(5)
49 S $P(ND4,U,7)=DUZ I PSGOEAV,PSJSYSU D
50 .S $P(ND4,U,PSJSYSU,PSJSYSU+1)=DUZ_U_+$P(DATA0,"^",5),$P(ND4,U,+PSJSYSU=1+9)=1,$P(ND4,U,+PSJSYSU=3+9)=0
51 .S $P(ND4,U,9,10)=+$P(ND4,U,9)_U_+$P(ND4,U,10)
52 .I '$P(ND4,U,9) S ^PS(55,"APV",PSGP,DA)=""
53 .I '$P(ND4,U,10) S ^PS(55,"NPV",PSGP,DA)=""
54 .I $P(ND4,U,9) K ^PS(55,"APV",PSGP,DA)
55 .I $P(ND4,U,10) K ^PS(55,"NPV",PSGP,DA)
56 S F="^PS(55,"_PSGP_",5,"_DA_",",@(F_"0)")=ND0
57 ;naked reference on the four (4) lines below refer to the full ref to ^PS(55,PSGP,5,DA created by indirection using variable F
58 I $G(INSTR)]"" S @(F_".3)")=INSTR
59 S @(F_".2)")=PSGPDRG_U_PSGDO S $P(^(.2),U,3,6)=$G(ORDCON)_"^"_$E(PRIORITY,2)_"^"_$G(DOSE)_"^"_$G(UNIT)
60 S @(F_"2)")=ND2,^(4)=ND4
61 S (C,X)=0 F S X=$O(^TMP("PSB",$J,700,X)) Q:'X S D=$G(^(X,0)) I D S C=C+1,@(F_"1,"_C_",0)")=$P(D,U,1,2),@(F_"1,""B"","_+D_","_C_")")=""
62 S:C @(F_"1,0)")=U_"55.07P^"_C_U_C
63 I $D(PROCOM) D
64 .;naked refs on the three lines below refer to the full ref to ^PS(55,PSGP,5,DA created by indrection using variable F
65 .I '$D(@(F_"12,0)")) S ^(0)=U_55.0612_U_0_U_0
66 .S JJ=0 F S JJ=$O(PROCOM(JJ)) Q:'JJ S $P(@(F_"12,0)"),"^",3,4)=JJ_"^"_JJ,@(F_"12,"_JJ_",0)")=PROCOM(JJ)
67 S @(F_"6)")=$$ENPC^PSJHL11("U",180)
68 D CRA^PSGOETO
69 L -^PS(55,DFN,5,DA)
70 S PSGORD=DA_"U"
71OUT ;
72 Q
73 ;
74CHK(X,Y,Z) ;Check for required fields
75 ; Input: X="^^"_MED ROUTE_"^^^^"_SCH TYPE
76 ; Y=ORDERABLE ITEM_"^"_DOSAGE ORDERED
77 ; Z=SCHEDULE_"^"_START DATE/TIME_"^^"_STOP DATE/TIME
78 D CHK^PSJHL7(X,Y,Z)
79 Q
80 ;
81DDOK(PSJF,OI) ;Check to be sure all dispense drugs that are active in the
82 ;order are valid.
83 ; Input: PSJF - File root of the order including all but the IEN of
84 ; the drug. (EX "^PS(53.45,X,2,")
85 ; OI - IEN of the order's orderable item
86 ; Output: 1 - all active DD's in the order are valid
87 ; 0 - no DD's active DD's or at least one active is invalid
88 N DDCNT,ND,PSJ,PSJ1 S (PSJ1,DDCNT)=0
89 I '$D(PSGDT) D NOW^%DTC S PSGDT=+$E(%,1,12)
90 I '$O(@(PSJF_"0)")) Q 1
91 ; Naked reference below refers to ^PS(53.45, created using indirection in variable PSJF
92 F PSJ=0:0 S PSJ=$O(@(PSJF_PSJ_")")) Q:'PSJ S ND=$G(@(PSJF_PSJ_",0)")) D
93 .S DDCNT=DDCNT+1
94 .S PSJ1=$S('$D(^PSDRUG(+ND,0)):1,$P($G(^(2)),U,3)'["U":1,+$G(^(2))'=+OI:1,$G(^("I"))="":0,1:^("I")'>PSGDT)
95 Q $S('DDCNT:0,PSJ1=1:0,1:1)
96 ;
97IVSET ;
98 N P,DFN S DFN=PSJHLDFN,CHK=""
99 F X=1:1:23 S P(X)=""
100 S (P(2),P(3),P("NINITDT"))=+$P(DATA0,"^",5),P("LOG")=LOGIN,P(4)=$P(DATA0,"^",3),P(5)=$S(P(4)="S":$P(DATA0,"^",4),1:""),P(6)=PROVIDER,P(8)=$G(INFRT),P(9)=$G(SCHEDULE),P(17)="E",P(21)=PSJORDER,P(22)=LOC
101 S:P(4)="P" P(9)=$P(DATA0,"^",6)
102 I P(4)="S",P(5)=1 S P(9)=$P(DATA0,"^",6)
103 S P("MR")=$S(P(4)="P":$O(^PS(51.2,"B","IV PIGGYBACK",0)),1:$O(^PS(51.2,"B","INTRAVENOUS",0)))
104 S (P("CLRK"),P("NINIT"))=CLERK,P("PD")=PSITEM,(P("IVRM"),P("SYRS"),P("CLIN"),P("FRES"),P("OPI"))="",P("RES")=ROC,P("PRY")=$E(PRIORITY,2),P("REM")=""
105 I $$SCHREQ^PSJLIVFD(.P),P(15)'>0 N P15 S P15=$$INTERVAL^PSIVUTL(.P)
106 D CHKIV I CHK D ERROR Q
107 D SETN
108 D NEW55^PSIVORFB
109 N DA,DIK,ND,PSIVACT
110 S ND(0)=+ON55 F X=2:1:23 I $D(P(X)) S $P(ND(0),U,X)=P(X)
111 S ND(.3)=$G(P("INS"))
112 S $P(ND(0),U,17)="E",ND(1)=P("REM"),ND(3)=P("OPI"),ND(.2)=$P($G(P("PD")),U)_U_$G(P("DO"))_U_+P("MR")_U_$G(P("PRY"))_U_$G(ORDCON) F X=0,1,3,.2,.3 S ^PS(55,DFN,"IV",+ON55,X)=ND(X)
113 S $P(^PS(55,DFN,"IV",+ON55,2),U,1,4)=P("LOG")_U_P("IVRM")_U_U_P("SYRS"),$P(^(2),U,8,10)=P("RES")_U_$G(P("FRES"))_U_$S($G(VAIN(4)):+VAIN(4),1:"")
114 S $P(^PS(55,DFN,"IV",+ON55,2),U,11)=+P("CLRK")
115 S:+$G(P("CLIN")) $P(^PS(55,DFN,"IV",+ON55,"DSS"),"^")=P("CLIN")
116 S:+$G(P("NINIT")) ^PS(55,DFN,"IV",+ON55,4)=P("NINIT")_U_P("NINITDT")_"^^^^^^^^"_"1"
117 S ^PS(55,"APIV",DFN,+ON55)=""
118 I $D(PROCOM) D
119 .I '$D(^PS(55,DFN,"IV",+ON55,5,0)) S ^(0)=U_55.1115_U_0_U_0
120 .S JJ=0 F S JJ=$O(PROCOM(JJ)) Q:'JJ S $P(^PS(55,DFN,"IV",+ON55,5,0),"^",3,4)=JJ_"^"_JJ,^PS(55,DFN,"IV",+ON55,5,JJ,0)=PROCOM(JJ)
121 S ^PS(55,DFN,"IV",+ON55,3)=$$ENPC^PSJHL11("V",60)
122 F DRGT="AD","SOL" D PUTD55
123 K DA,DIK S DA(1)=DFN,DA=+ON55,DIK="^PS(55,"_DA(1)_",""IV"",",PSIVACT=1 D IX^DIK
124 L -^PS(55,DFN,"IV",DA)
125 S PSGORD=ON55
126 Q
127 ;
128PUTD55 ; Move drug data from local array into 55
129 K ^PS(55,DFN,"IV",+ON55,DRGT) S ^PS(55,DFN,"IV",+ON55,DRGT,0)=$S(DRGT="AD":"^55.02PA",1:"^55.11IPA")
130 F X=0:0 S X=$O(^TMP("PSB",$J,$S(DRGT="AD":800,1:900),X)) Q:'X D
131 .S Y=^PS(55,DFN,"IV",+ON55,DRGT,0),$P(Y,U,3)=$P(Y,U,3)+1,DRG=$P(Y,U,3),$P(Y,U,4)=$P(Y,U,4)+1
132 .S ^PS(55,DFN,"IV",+ON55,DRGT,0)=Y,^PS(55,DFN,"IV",+ON55,DRGT,+DRG,0)=$P(^TMP("PSB",$J,$S(DRGT="AD":800,1:900),X,0),"^")_"^"_$P(^TMP("PSJNVO",$J,DRGT,+DRG,0),"^",2)
133 Q
134 ;
135SETN ;Set up patient 0 node if needed.
136 I '$D(^PS(55,DFN,0)) K DO,DA,DD,DIC,PSIVFN S:$D(^(5.1)) PSIVFN=^(5.1) K:$D(PSIVFN) ^(5.1) S (DINUM,X)=DFN,DIC(0)="L",DIC="^PS(55," D FILE^DICN S:$D(PSIVFN) ^PS(55,DFN,5.1)=PSIVFN D K DIC,PSIVFN,DO,DA,DD
137 .; Mark PSJ and PSO as converted
138 .S $P(^PS(55,DFN,5.1),"^",11)=2
139 Q
140 ;
141CHKIV ;Validate IV data
142 N OK S OK=0
143 I "APS"'[P(4) S CHK=1,PSREASON="Invalid IV Type" Q
144 I P(9)="",P(4)="P" S CHK=1,PSREASON="Piggyback IV Type requires a schedule" Q
145 I P(4)="S",P(5)=1,P(9)="" S CHK=1,PSREASON="Intermittent Syringe IV Type requires a schedule" Q
146 I P(9)'="STAT",(P(9)'="NOW"),P(9)'="" S CHK=1,PSREASON="Invalid Schedule" Q
147 I ORDCON'="V",ORDCON'="P" S CHK=1,PSREASON="Invalid Nature of Order" Q
148 I +$G(^TMP("PSB",$J,800,0))=0,+$G(^TMP("PSB",$J,900,0))=0 S CHK=1,PSREASON="IV orders must have at least one additive or solution" Q
149 I +$G(^TMP("PSB",$J,900,0))=0,P(4)'="P" S CHK=1,PSREASON="You must have at least one solution for this order." Q
150 I +$G(^TMP("PSB",$J,800,0))'=+$G(^TMP("PSJNVO",$J,"AD",0)) S CHK=1,PSREASON="Number of additives in BCMA & CPRS do not match." Q
151 I +$G(^TMP("PSB",$J,900,0))'=+$G(^TMP("PSJNVO",$J,"SOL",0)) S CHK=1,PSREASON="Number of solutions in BCMA & CPRS do not match." Q
152 F DRGT="AD","SOL" S FIL=$S(DRGT="AD":52.6,1:52.7) F DRGI=0:0 S DRGI=$O(^TMP("PSB",$J,$S(DRGT="AD":800,1:900),DRGI)) Q:'DRGI S DRG=$G(^TMP("PSB",$J,$S(DRGT="AD":800,1:900),DRGI,0)) D DRG,@DRGT Q:CHK=1
153 I 'OK,'CHK S CHK=1,PSREASON="The Orderable Item does not match any of the additives or solutions in this order" Q
154 Q
155 ;
156AD ;Check additives
157 I '$D(^PS(FIL,+DRG,0)) S CHK=1,PSREASON="Additive "_+DRG_" does not exist in the additive file" Q
158 ;Naked reference below refers to ^PS(52.6,+DRG,0)
159 I $P(^(0),"^",11)=PSITEM S OK=1
160 I $$ENU^PSIVUTL(+DRG)'=$P($P(^TMP("PSJNVO",$J,DRGT,+DRGI,0),"^",2)," ",2,99)!(+$P(^TMP("PSJNVO",$J,DRGT,+DRGI,0),"^",2)'>0) S CHK=1,PSREASON="Invalid strength entered for additive "_+DRG Q
161 Q
162SOL ;Check solutions
163 I '$D(^PS(FIL,+DRG,0)) S CHK=1,PSREASON="Solution "_+DRG_" does not exist in the solution file" Q
164 ;Naked reference below refers to ^PS(52.7,+DRG,0)
165 I $P(^(0),"^",11)=PSITEM S OK=1
166 I +$P(^TMP("PSJNVO",$J,DRGT,+DRGI,0),"^",2)>9999!(+$P(^TMP("PSJNVO",$J,DRGT,+DRGI,0),"^",2)'>0) S CHK=1,PSREASON="Volume on "_+DRG_" is an invalid strength" Q
167 Q
168DRG ;Check to be sure additive/solutions are active
169 I $S('$G(^PS(FIL,+DRG,"I")):0,^("I")>DT:0,1:1) S CHK=1,PSREASON="An additive or solution is inactive" Q
170 Q
Note: See TracBrowser for help on using the repository browser.