source: FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL4A.m@ 1008

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

initial load of FOIAVistA 6/30/08 version

File size: 5.8 KB
Line 
1PSJHL4A ;BIR/RLW-CONTINUE DECODE HL7 /MESSSAGE FROM OE/RR ;16 Mar 99 / 4:55 PM
2 ;;5.0; INPATIENT MEDICATIONS ;**105,111,154,170,159**;16 DEC 97;Build 15
3 ;
4 ; Reference to ^PS(52.6 is supported by DBIA# 1231.
5 ; Reference to ^PS(52.7 is supported by DBIA# 2173.
6 ; Reference to ^PS(55 is supported by DBIA# 2191.
7 ; Reference to ^PS(59.7 supported by DBIA #2181.
8 ;
9RXC ; IV order
10 N IVFL
11 S APPL=FIELD(1)
12 I APPL["B" S SOLCNT=SOLCNT+1,PTR=$P(FIELD(2),"^",4) Q:'PTR S VOLUME=+FIELD(3)_" ML" D I '$D(^TMP("PSJNVO",$J,"SOL",SOLCNT,0)) D SOLSRCH
13 .S SOLUTION="" F S SOLUTION=$O(^PS(52.7,"AOI",PTR,SOLUTION)) Q:'SOLUTION S INACT=$G(^PS(52.7,SOLUTION,"I")) I 'INACT!(INACT>DT) I VOLUME=$P(^PS(52.7,SOLUTION,0),U,3) D
14 ..S ^TMP("PSJNVO",$J,"SOL",0)=SOLCNT
15 ..S ^TMP("PSJNVO",$J,"SOL",SOLCNT,0)=SOLUTION_"^"_VOLUME,TVOLUME=TVOLUME+(+VOLUME)
16 I $G(INFRT)]"" S X=INFRT D ENI^PSJHLU S INFRT=$G(X)
17 I APPL="A" S ADCNT=ADCNT+1,PTR=$P(FIELD(2),"^",4) Q:'PTR S STRENGTH=$G(FIELD(3))_" "_$P($G(FIELD(4)),"^",5) D I '$D(^TMP("PSJNVO",$J,"AD",ADCNT,0)) S PSREASON="Can't find matching additive" D ERROR^PSJHL9 Q
18 .S ADDITIVE="" F S ADDITIVE=$O(^PS(52.6,"AOI",PTR,ADDITIVE)) Q:'ADDITIVE S INACT=$G(^PS(52.6,ADDITIVE,"I")),IVFL=$P($G(^(0)),"^",13) I 'INACT!(INACT>DT),IVFL'=0 Q:$G(^PS(52.6,ADDITIVE,0))']"" D Q:ADDITIVE
19 ..I $G(PSITEM)="" S PSITEM=PTR
20 ..S ^TMP("PSJNVO",$J,"AD",0)=ADCNT
21 ..S ^TMP("PSJNVO",$J,"AD",ADCNT,0)=ADDITIVE_"^"_STRENGTH
22 Q
23 ;
24RXO ;
25 I $O(PSJMSG(II,0)) D
26 .K SEGMENT
27 .N KK,JJ,XX
28 .S SEGMENT(1)=$G(PSJMSG(II))
29 .S KK=1,JJ="" F S JJ=$O(PSJMSG(II,JJ)) Q:'JJ S KK=KK+1,SEGMENT(KK)=$G(PSJMSG(II,JJ))
30 .S KK=1,JJ=0
31 .F Q:'$D(SEGMENT(KK)) D
32 ..I SEGMENT(KK)["|" S FIELD(JJ)=$P(SEGMENT(KK),"|"),SEGMENT(KK)=$E(SEGMENT(KK),$L(FIELD(JJ))+2,$L(SEGMENT(KK))),JJ=JJ+1 Q
33 ..I SEGMENT(KK)'["|" S FIELD(JJ)=SEGMENT(KK),KK=KK+1 Q:'$D(SEGMENT(KK)) D
34 ...S XX=$P(SEGMENT(KK),"|"),SEGMENT(KK)=$E(SEGMENT(KK),$L(X)+2,$L(SEGMENT(KK))),FIELD(JJ)=FIELD(JJ)_XX,JJ=JJ+1
35 S APPL="",PSITEM=$S($P(FIELD(1),"^",5)="IV":"",1:$P(FIELD(1),"^",4))
36 S:$P(FIELD(1),"^",6)="ORD" PSITEM=""
37 S:$P(FIELD(1),"^",5)="IV" IVTYP="A",SCHTYP="C",INFRT=$G(FIELD(2))
38 S DISPENSE=$P($G(FIELD(10)),"^",4)
39 S IVLIMIT=$P($G(PSJMSG(II)),"^",3)
40 Q
41 ;
42OBX ;
43 S OBXFL=1,OCNARR=FIELD(5),OCPROV=CLERK,OCCNT=OCCNT+1
44 S ^TMP("PSJNVO",$J,10,0)=OCCNT
45 S ^TMP("PSJNVO",$J,10,OCCNT,0)=OCNARR
46 S ^TMP("PSJNVO",$J,10,OCCNT,1)=$P($G(^VA(200,+OCPROV,0)),"^")
47 Q
48 ;
49NTE ;
50 S TEXT=$S((FIELD(1)=6)&('OBXFL):"PROCOM",(FIELD(1)=7)&('OBXFL):"ADMINSTR",1:"OCRSN")
51 S @TEXT@(1)=$G(FIELD(3))
52 S K=1,J="" F S J=$O(PSJMSG(II,J)) Q:'J S K=K+1,@TEXT@(K)=$G(PSJMSG(II,J))
53 D:$D(OCRSN)
54 .S QQ=0 F S QQ=$O(OCRSN(QQ)) Q:'QQ S ^TMP("PSJNVO",$J,10,OCCNT,2,QQ,0)=OCRSN(QQ)
55 S OBXFL=0
56 Q
57 ;
58ZRX ;
59 N ND,ND2,CHK,FOLOR,STDT
60 S PREON=$G(FIELD(1)),ROC=$G(FIELD(3))
61 S ND=$S((PREON["N")!(PREON["P"):$G(^PS(53.1,+PREON,0)),PREON["V":$G(^PS(55,PSJHLDFN,"IV",+PREON,0)),1:$G(^PS(55,PSJHLDFN,5,+PREON,0)))
62 S ND2=$S((PREON["N")!(PREON["P"):$G(^PS(53.1,+PREON,2)),PREON["V":$G(^PS(55,PSJHLDFN,"IV",+PREON,2)),1:$G(^PS(55,PSJHLDFN,5,+PREON,2)))
63 I 'ND I ROC'="N" S PSREASON="Invalid Pharmacy order number" D ERROR^PSJHL9 Q
64 I ND I ROC="R" S FOLOR=$S(PREON["V":$P(ND2,U,6),1:$P(ND,U,26)) I FOLOR S PSREASON="Duplicate Renewal Request" D ERROR^PSJHL9 Q
65 I ND I ROC="R" S CHK=$S(PREON["V":$P(ND,U,17),1:$P(ND,U,9)) I "AE"'[CHK S PSREASON="Pharmacy orders with a status of "_CHK_" may not be renewed" D ERROR^PSJHL9 Q
66 I $G(CHK)="E" I PREON'["V" D NOW^%DTC S X1=+$E(%,1,12),X2=-4 D C^%DTC S STDT=$S(PREON["V":$P(ND,U,3),1:$P(ND2,U,4)) I STDT'>X S PSREASON="Pharmacy orders expired longer than 4 days may not be renewed" D ERROR^PSJHL9 Q
67 I ND I ROC="E" S FOLOR=$S(PREON["V":$P(ND2,U,6),1:$P(ND,U,26)) I FOLOR S PSREASON="Pharmacy orders may only be edited ONCE" D ERROR^PSJHL9 Q
68 I ND I ROC="E" S CHK=$S(PREON["V":$P(ND,U,17),1:$P(ND,U,9)) I "DEHO"[CHK N CHKRTN S CHKRTN=CHK_"^PSJHL6" D @CHKRTN S PSREASON=PSREASON_" orders may not be edited" D ERROR^PSJHL9 Q
69 D:ROC'="R" VALID^PSJHL9 Q:QFLG
70 I $G(PSITEM)="",$D(^TMP("PSJNVO",$J,"SOL",1,0)) S PSITEM=$P($G(^PS(52.7,+^TMP("PSJNVO",$J,"SOL",1,0),0)),"^",11)
71 I PRIORITY="ZD" D VALID^PSJHL10 S QFLG=1 Q
72 I (PREON]"")&(ROC="E") D EDITCK^PSJHL5 Q:QFLG
73 D NVO^PSJHL9
74 I (PREON]"")&(ROC="R") D RENEW^PSJHL7 Q
75 I (PREON]"")&(ROC="E") D EDIT^PSJHL5
76 Q
77 ;
78SOLSRCH ;Find solution
79 N SSSS,SEG,ON,ROC,SOL,SOL2
80 F SSSS=II:0 S SSSS=$O(PSJMSG(SSSS)) Q:'SSSS I $P(PSJMSG(SSSS),"|")="ZRX" D Q
81 .S SEG=$G(PSJMSG(SSSS)),ON=$P(SEG,"|",2),ROC=$P(SEG,"|",4)
82 I $G(ROC)'="N" F SOL=0:0 S SOL=$O(^PS(55,PSJHLDFN,"IV",+ON,"SOL",SOL)) Q:'SOL S SOL2=$G(^PS(55,PSJHLDFN,"IV",+ON,"SOL",SOL,0)) I $D(^PS(52.7,"AOI",PTR,+SOL2))&($P(SOL2,U,2)=VOLUME) S SOLUTION=+SOL2 D SET Q
83 I 'SOLUTION S SOLUTION=$O(^PS(52.7,"AOI",PTR,SOLUTION)) D SET
84 Q
85SET ;Set solution tmp nodes
86 Q:'+SOLUTION
87 S ^TMP("PSJNVO",$J,"SOL",0)=SOLCNT
88 S ^TMP("PSJNVO",$J,"SOL",SOLCNT,0)=SOLUTION_"^"_VOLUME,TVOLUME=TVOLUME+(+VOLUME)
89 Q
90 ;
91SNDTSTW(PRIO,PSJSCHED,WARD) ; Test to determine if mail message should be sent.
92 N SNPRIO,SNSCHD,SNOPT
93 S SNPRIO=$S(PRIO="S":"S",PRIO="A":"A",1:"R")
94 S SNSCHD=$S(PSJSCHED="STAT":"S",PSJSCHED="NOW":"N",1:"R")
95 S SNOPT=$P($G(^PS(59.6,WARD,0)),"^",32)
96 S:SNOPT="" SNOPT=$P($G(^PS(59.7,1,27)),"^",1)
97 Q:SNOPT="" 0
98 Q:SNOPT[SNPRIO 0
99 Q:SNOPT[SNSCHD 0
100 Q 1
101 ;
102SNDTSTP(PRIO,PSJSCHED) ; Test to determine if mail message should be sent.
103 N SNPRIO,SNSCHD,SNOPT
104 S SNPRIO=$S(PRIO="S":"S",PRIO="A":"A",1:"R")
105 S SNSCHD=$S(PSJSCHED="STAT":"S",PSJSCHED="NOW":"N",1:"R")
106 S SNOPT=$P($G(^PS(59.7,1,27)),"^",1)
107 Q:SNOPT="" 1
108 Q:SNOPT[SNPRIO 0
109 Q:SNOPT[SNSCHD 0
110 Q 1
111 ;
112SNDTSTA(PRIO,PSJSCHED) ; Test to determine if mail message should be sent.
113 N SNPRIO,SNSCHD,SNOPT
114 S SNPRIO=$S(PRIO="S":"S",PRIO="A":"A",1:"R")
115 S SNSCHD=$S(PSJSCHED="STAT":"S",PSJSCHED="NOW":"N",1:"R")
116 S SNOPT=$P($G(^PS(59.7,1,27)),"^",2)
117 S:SNOPT="" SNOPT=$P($G(^PS(59.7,1,27)),"^",1)
118 Q:SNOPT="" 1
119 Q:SNOPT[SNPRIO 0
120 Q:SNOPT[SNSCHD 0
121 Q 1
Note: See TracBrowser for help on using the repository browser.