source: FOIAVistA/trunk/r/CMOP-PSX/PSXBLD.m@ 1416

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

initial load of FOIAVistA 6/30/08 version
File size: 9.3 KB
Line 
1PSXBLD ;BIR/BAB-Build HL7 Data for CMOP Rx Queue ;24 Jun 2002 5:19 PM
2 ;;2.0;CMOP;**3,23,29,28,43,41,50,54**;11 Apr 97;Build 6
3 ;
4 ;Reference to ^PSRX( supported by DBIA #1977
5 ;Reference to ^PSDRUG( supported by DBIA #1983
6 ;Reference to ^PS(51, supported by DBIA #1980
7 ;Reference to ^PS(52.5 supported by DBIA #1978
8 ;Reference to ^PS(53, supported by DBIA #1975
9 ;Reference to ^PS(55, supported by DBIA #2228
10 ;Reference to ^PS(59, supported by DBIA #1976
11 ;Reference to ^PS(59.7, supported by DBIA #694
12 ;Reference to ^DPT( supported by DBIA #3097
13 ;Reference to IBCP^PSOLBL supported by DBIA #2477
14 ;Reference to OTHL1^PSOLBL3 supported by DBIA #4071
15 ;Reference to EN^PSOHLSN1 supported by DBIA #2385
16 ;Reference to PROD2^PSNAPIS supported by DBIA #2531
17 ;Reference to DRUG^PSSWRNA supported by DBIA #4449
18EN ; build entries into 550.1 by alpha patient
19 D SET^PSXSYS
20 ;Clear 550.1
21 ; of entries
22 K DIK,DA S DIK="^PSX(550.1,",DA=0 F S DA=$O(^PSX(550.1,DA)) Q:DA'>0 D ^DIK
23 ; walk down the PTNM,DFN,RX,FILL 'C' index of PSX(550.2,PSXBAT,15,'C' - RX multiple
24 ; Alpha order by patient name
25 S PSXNM="",ZCNT=0,PSXMSG=0 ;PSXMSG now starts at 1 every batch incremented in NEWMSG^PSXRXQU
26 S PSSWSITE=+$O(^PS(59.7,0))
27 F S PSXNM=$O(^PSX(550.2,PSXBAT,15,"C",PSXNM)) Q:PSXNM']"" D
28 . S DFN="" F S DFN=$O(^PSX(550.2,PSXBAT,15,"C",PSXNM,DFN)) Q:DFN'>0 D
29 .. S MSG=0 K PSX,PSXORD
30 .. D NEWMSG^PSXRXQU,ORD,MRX^PSXBLD1,LOADMSG^PSXRXQU
31 D DIV^PSXBLD1 ;build NTE1
32 K MSG,PSXNM,DFN,RX,RXF,REG,PSCAP,X,Y,PSXPTR,PSSWSITE
33 Q
34ORD ; PSXMSG was returned by call to NEWMSG^PSXRXQU
35 ; Loop RXs, RXFs in Transmission PSXBAT
36 S REG=$S($P($G(^PS(55,DFN,0)),"^",3)=1:1,1:""),PSCAP=+$P($G(^PS(55,DFN,0)),"^",2),RX=0 K RXY,RXY1
37 S RX=0 F S RX=$O(^PSX(550.2,PSXBAT,15,"C",PSXNM,DFN,RX)) Q:RX'>0 D
38 . S REC=$O(^PS(52.5,"B",RX,0))
39 . I 'REC D DEL5502 Q ;RX was removed from 52.5 during transmission
40 . S RXY=^PSRX(RX,0),RXF=$O(^PSX(550.2,PSXBAT,15,"C",PSXNM,DFN,RX,0))
41 . S PTR=RX S:RXF>0 RXY1=$G(^PSRX(RX,1,RXF,0)) D ORC ;builds RX HL7 segments into PSXORD(
42 . I PSXFLAG=1 S ^PS(52.5,REC,"P")=1,^PS(52.5,"ADL",DT,REC)="" ;update print node
43 . D RXMSG^PSXRXQU ;put RX,RXF into PSXMSG 550.1 RX multiple ; returns PSXRXMDA
44 . ;D FILE^PSXRXU ;update 52 & 52.5
45 . I PSXFLAG=1 D EN^PSOHLSN1(RX,"SC","ZU","Transmitted to CMOP","")
46 K PSCLN,ZDU,FDT,DRUG,RXN,WARN,TECH,QTY,PHYS,DAYS,LSTFIL,COPAY,DEA,P,PTST,REF,VRPH,RXY,RXY1
47 Q
48ORC ;builds RX HL7 segments into PSXORD(
49 Q:($G(RXF)>0&($G(RXY1)=""))
50 N PSOLBLCP
51 S PSX(RX)=RXF,MSG=MSG+1,FDT=$P(^PSRX(RX,2),"^",2),PSXORD(MSG)="ORC|NW|"
52 S X=+$G(^PSRX(RX,"IB")),COPAY=$S(X=1:1,X=2:1,1:"") K X S RXN=$P(RXY,"^"),VRPH=$P($G(^PSRX(RX,2)),"^",10)
53 D COPAYCK ; DO ADDITIONAL CHECKS TO DETERMINE CURRENT COPAY STATUS
54 S (DRUG,WARN,DEA)="" I $D(^PSDRUG(+$P(RXY,"^",6),0)) S DRUG=$P(^(0),"^"),WARN=$P(^(0),"^",8),DEA=$P(^(0),"^",3) S Y=DRUG D STRIP S DRUG=Y K Y
55 I '$D(PSSWSITE) S PSSWSITE=+$O(^PS(59.7,0))
56 I $P($G(^PS(59.7,PSSWSITE,10)),"^",10)="N" D
57 .S WARN=$$DRUG^PSSWRNA(+$P(RXY,"^",6),DFN)
58 I $G(DRUG) S ZDU=$P($G(^PSDRUG(DRUG,660)),"^",8)
59 S ISD=$P(RXY,"^",13),ISD=ISD+17000000
60 G:RXF>0 REF
61 S TECH=+$P(RXY,"^",16),QTY=$P(RXY,"^",7),PHYS=$S($D(^VA(200,+$P(RXY,"^",4),0)):$P(^(0),"^"),1:"UNKNOWN"),DAYS=$P(RXY,"^",8)
62 S ZFIL=$G(^PSRX(RX,3))
63 S LSTFIL=$S(+$P(ZFIL,"^",4):$P(ZFIL,"^",4),1:+$P(ZFIL,"^"))
64 S LSTFIL=LSTFIL+17000000
65 S EXPDT=$P(^PSRX(RX,2),U,6) S:+EXPDT EXPDT=EXPDT+17000000
66 G RX1
67REF ;
68 S TECH=+$P(RXY1,"^",7),QTY=$P(RXY1,"^",4),PHYS=$S($D(^VA(200,+$P(RXY1,"^",17),0)):$P(^(0),"^"),1:"UNKNOWN"),DAYS=$P(RXY1,"^",10)
69 S FDT=$P(RXY1,"^")
70 S ZFIL=$G(^PSRX(RX,3))
71 S LSTFIL=$S(+$P(ZFIL,"^",4):$P(ZFIL,"^",4),1:+$P(ZFIL,"^"))
72 S LSTFIL=LSTFIL+17000000
73 S EXPDT=$P(^PSRX(RX,2),"^",6),EXPDT=EXPDT+17000000
74RX1 ;
75 S X="RX1|",$P(X,"|",13)=QTY,$P(X,"|",21)=ISD,$P(X,"|",25)=EXPDT
76 S $P(X,"|",2)=+$P(PSXSYS,"^",2)_"-"_$P(RXY,"^")_"-"_(RXF+1)
77 S Y1=$P($G(^PSDRUG($P(RXY,"^",6),"ND")),U,3)
78 D DGST
79 S $P(X,"|",15)=$S($L($G(PSXDGST)):PSXDGST_"^L",1:"^^L")
80 S $P(X,"|",20)=$P(RXY,"^",9),$P(X,"|",22)=+$P(RXY,"^",9)-RXF
81 S $P(X,"|",26)=LSTFIL,$P(X,"|",27)=$P(RXY,"^")
82 K ZFIL S MSG=MSG+1,PSXORD(MSG)=X_"||||",FLG=0 D SIG K MAX,FLG,X
83ZX1 ;
84 S REFDIV=$S($P($G(^PS(59.7,1,40.1)),"^",4):$P(^(40.1),"^",4),1:PSOSITE)
85 S X="ZX1|"_$P(RXY,"^")_"|"_$P($G(^PS(59,REFDIV,0)),"^",6)_"^"_$P($G(^(0)),"^")_"|M|"
86 K REFDIV
87 ; Count number of CMOP rxs for this patient order
88 S Y=1,Y1=RX F S Y1=$O(^TMP($J,"PSX",PSXNM,DFN,Y1)) Q:'Y1 S Y=Y+1
89 S $P(X,"|",5)=Y,$P(X,"|",6)="("_(RXF+1)_"of"_(1+$P(RXY,"^",9))_")",$P(X,"|",8)=REG K Y,Y1 S $P(X,"|",7)=$S($D(^VA(200,+$P(^PSRX(RX,0),"^",4),0)):$E($P(^(0),"^",1),1,20),1:"UNKNOWN"),$P(X,"|",8)=REG K Y,Y1
90 S VRPH=$P(^PSRX(RX,2),"^",10),$P(X,"|",9)="("_$G(TECH)_"/"_$S($D(VRPH):VRPH,1:" ")_")" S:$L($P(X,"|",9))>12 $P(X,"|",9)="(***/***)"
91 I '+$G(PSOINST) D:'+$G(PSXSYS) SET^PSXSYS S PSOINST=+$P(PSXSYS,"^",2)
92 S $P(X,"|",10)=1700+$E(FDT,1,3)_$E(FDT,4,7),$P(X,"|",11)=COPAY,$P(X,"|",13)=PSCAP,$P(X,"|",14)=DAYS,$P(X,"|",16)=PSOINST_"-"_RX
93 ;Addition for CS transmissions...1 if CS, "" if not...
94 S PSXCSB=$P(^PSRX(RX,0),"^",6),PSXCSC=$P($G(^PSDRUG(PSXCSB,0)),"^",3)
95 F PSXCSD=3:1:5 I PSXCSC[PSXCSD S PSXCSRX=1
96 S $P(X,"|",15)=$G(PSXCSRX) K PSXCSRX,PSXCSC,PSXCSB,PSXCSD
97 D WARN
98 S PTST=$G(^PS(53,$P(RXY,"^",3),0)),RNEW=1,REF=+$P(^PSRX(RX,0),"^",9)-RXF S:REF<0 REF=0 I REF=0 S:('$P(PTST,"^",5))!(DEA["A"&(DEA'["B"))!(DEA["W") RNEW=0
99 S $P(X,"|",12)=RNEW,PTST=$P(PTST,"^",2),PSCLN=+$P(RXY,"^",5),PSCLN=$S($D(^SC(PSCLN,0)):$P(^(0),"^",1),1:"UNKNOWN") S $P(X,"|",18)=$E((PTST),1,20),$P(X,"|",19)=$E(PSCLN,1,20)
100 ;
101 K RNEW,SIG,SGY,ISD,EXPDT
102 S MSG=MSG+1,PSXORD(MSG)=X
103 S PSSWSITE=+$O(^PS(59.7,0))
104 I $P($G(^PS(59.7,PSSWSITE,10)),"^",10)="N" D NEWWARN^PSXBLD2
105 Q
106A I $D(^PS(51,"A",X)) S %=^(X),X=$P(%,"^",1) I $P(%,"^",2)'="" S Y=$P(SIG," ",P-1),Y=$E(Y,$L(Y)) S:Y>1 X=$P(%,"^",2)
107 I (+$G(FLG)=0)&(($L(SGY)+$L(X))'>70) S SGY=SGY_X_" " Q
108 I (+$G(FLG)=1)&(($L(SGY)+$L(X))'>100) S SGY=SGY_X_" " Q
109 I $G(FLG)=1 S MSG=MSG+1,PSXORD(MSG)=$TR("NTE|7||"_SGY,"\","/"),SGY=X_" " Q
110 S PSXORD(MSG)=$TR(PSXORD(MSG)_SGY,"\","/"),SGY=X_" ",FLG=1
111 Q
112SIG ;
113 G:($P(^PSRX(RX,"SIG"),"^",2)=1) EXPAND
114 S SIG=$P(^PSRX(RX,"SIG"),"^")
115 S SGY="" F P=1:1:$L(SIG," ") S X=$P(SIG," ",P) D A:X]""
116 I SGY]"",FLG=0 S PSXORD(MSG)=$TR(PSXORD(MSG)_SGY,"\","/")
117 I SGY]"",FLG=1 S MSG=MSG+1,PSXORD(MSG)=$TR("NTE|7||"_SGY,"\","/")
118 I $D(^DPT(DFN,"NHC")),^("NHC")="Y" S MSG=MSG+1,PSXORD(MSG)=$TR("NTE|7||Exp:______ Mfg:______","\","/")
119 K SIG,%,J,Z,SGY,X
120 Q
121STRIP ;strip out any HL7 delimiters
122 F %="|","~","^","\" F Q:Y'[% S Y=$P(Y,%,1)_" "_$P(Y,%,2,999)
123 ;replace "&" in sig with escape sequence "\T\"
124 ;S:Y["&" Y=$P(Y,"&",1)_"\T\"_$P(Y,"&",2,999)
125 Q
126EXPAND ;expands the sig
127 N NTESEQ
128 K ^UTILITY($J,"W") S DIWL=1,DIWR=80,DIWF="C80"
129 S XX=0 F S XX=$O(^PSRX(RX,"SIG1",XX)) Q:XX'>0 S X=^(XX,0) S Y=X D STRIP S X=Y D ^DIWP
130 S YY=0 F S YY=$O(^UTILITY($J,"W",1,YY)) Q:YY'>0 D
131 .I YY=1 S NTESEQ=1,PSXORD(MSG)=$TR($G(PSXORD(MSG))_$G(^(YY,0)),"\","/") Q
132 .S MSG=$G(MSG)+1,PSXORD(MSG)=$TR("NTE|7||"_$G(^(YY,0)),"\","/") D
133 ..I $P($G(^PS(59.7,PSSWSITE,10)),"^",10)="N" S PSXORD(MSG)=$P(PSXORD(MSG),"|",1,2)_"|"_$P(RXY,"^")_"|ENG|"_NTESEQ_"|"_$P(PSXORD(MSG),"|",4,99),NTESEQ=NTESEQ+1
134 .Q
135 K XX,YY,DIWL,DIWR,DIWF,X,Y,^UTILITY($J,"W"),Z
136 I $$PATCH^XPDUTL("PSO*7.0*117"),$P($G(^PS(55,DFN,"LAN")),"^",1),$P($G(^PS(55,DFN,"LAN")),"^",2)=2 D OTHL1^PSOLBL3(RX) D Q:'$O(SIG2(0)) ;ONLY SEND SPANISH SIG IF PMI PREF (ON PID SEGMENT) IS ALSO SPANISH
137 .S XX=0 F S XX=$O(SIG2(XX)) Q:'XX I $O(SIG2(XX))="",SIG2(XX)="" K SIG2(XX) Q ; IF LAST ENTRY IS NULL, REMOVE IT
138 S NTESEQ=1
139 S DIWL=1,DIWR=80,DIWF="C80",(XX,YY)=0
140 F S XX=$O(SIG2(XX)) Q:'XX S X=SIG2(XX) S Y=X D STRIP S X=Y D ^DIWP
141 S PSSWSITE=+$O(^PS(59.7,0))
142 F S YY=$O(^UTILITY($J,"W",1,YY)) Q:YY'>0 S MSG=$G(MSG)+1,PSXORD(MSG)=$TR("NTE|7||"_$G(^(YY,0)),"\","/") I $P($G(^PS(59.7,PSSWSITE,10)),"^",10)="N" D
143 .S PSXORD(MSG)=$P(PSXORD(MSG),"|",1,2)_"|"_$P(RXY,"^")_"|SPA|"_NTESEQ_"|"_$P(PSXORD(MSG),"|",4,99),NTESEQ=NTESEQ+1
144 K XX,YY,DIWL,DIWR,DIWF,X,Y,^UTILITY($J,"W"),SIG2,PSSWSITE
145 Q
146DGST ; returns PSXDGST
147 N RXNUM,RXEX,PTRA,PTRB,ZX,PSXPTR
148 S PSXPTR=RX K PSXDGST
149 S RXNUM=$P($G(^PSRX(PSXPTR,0)),"^",6),RXEX=$P($G(^PSRX(PSXPTR,0)),"^",1)
150 I $G(^PSDRUG(RXNUM,"ND"))'="" D
151 .S PTRA=$P($G(^PSDRUG(RXNUM,"ND")),U,1),PTRB=$P($G(^PSDRUG(RXNUM,"ND")),U,3)
152 .I $G(PTRA)'="" S ZX=$$PROD2^PSNAPIS(PTRA,PTRB),DRUGCHK=$P($G(ZX),"^",3)
153 S:$G(DRUGCHK)'="" PSXDGST=$P(ZX,"^",2)_"^"_$P(ZX,"^")
154 Q
155COPAYCK ; RECHECK COPAY STATUS FOR EACH FILL
156 N PSOLBLPS,PSOLBLDR,PSODBQ,PSOQI
157 S PSOLBLPS=+$P(RXY,"^",3),PSOLBLDR=+$P(RXY,"^",6)
158 I $P($G(^PS(53,+$G(PSOLBLPS),0)),"^",7) S COPAY="" Q
159 I $P($G(^PSDRUG(+$G(PSOLBLDR),0)),"^",3)["I"!($P($G(^(0)),"^",3)["S") S COPAY="" Q
160 S PSOQI=$G(^PSRX(RX,"IBQ"))
161 I PSOQI["1" S COPAY="" Q
162 I $G(PSOLBLCP)="" D IBCP^PSOLBL ; CHECK WHETHER EXEMPT (SC OR INCOME EXEMPT - OR IF SERVICE-CONNECTED QUESTION NEEDS TO BE ASKED KEEP COPAY AS IT WAS)
163 I $G(PSOLBLCP)=0 S COPAY="" Q
164 I $G(PSOLBLCP)=2,'$P($G(^PSRX(RX,"IB")),"^") S COPAY="" Q
165 S COPAY=1
166 Q
167 ;
168DEL5502 ; RX was removed from 52.5 during transmission
169 N DA,DIK
170 S DA=$O(^PSX(550.2,PSXBAT,15,"B",RX,0))
171 S DA(1)=PSXBAT,DIK="^PSX(550.2,"_DA(1)_",15," D ^DIK
172 Q
173WARN ;
174 I '$D(PSSWSITE) S PSSWSITE=+$O(^PS(59.7,0))
175 I $P($G(^PS(59.7,PSSWSITE,10)),"^",10)="N" Q
176 S L=+$L(WARN,",") S W1="" F J=1:1:L S W=$P(WARN,",",J) I +W>0,(+W'>20) S:+W1>0 W1=W1_"~"_W S:+W1=0 W1=W1_W
177 S:+W1>0 $P(X,"|",17)=W1 K WARN,J,W,L,W1
178 Q
Note: See TracBrowser for help on using the repository browser.