PSXBLD ;BIR/BAB-Build HL7 Data for CMOP Rx Queue ;24 Jun 2002 5:19 PM
;;2.0;CMOP;**3,23,29,28,43,41,50,54,98**;11 Apr 97;Build 5
;
;Reference to ^PSRX( supported by DBIA #1977
;Reference to ^PSDRUG( supported by DBIA #1983
;Reference to ^PS(51, supported by DBIA #1980
;Reference to ^PS(52.5 supported by DBIA #1978
;Reference to ^PS(53, supported by DBIA #1975
;Reference to ^PS(55, supported by DBIA #2228
;Reference to ^PS(59, supported by DBIA #1976
;Reference to ^PS(59.7, supported by DBIA #694
;Reference to ^DPT( supported by DBIA #3097
;Reference to ^PSRX( supported by DBIA #1977
;Reference to IBCP^PSOLBL supported by DBIA #2477
;Reference to OTHL1^PSOLBL3 supported by DBIA #4071
;Reference to EN^PSOHLSN1 supported by DBIA #2385
;Reference to PROD2^PSNAPIS supported by DBIA #2531
;Reference to DRUG^PSSWRNA supported by DBIA #4449
EN ; build entries into 550.1 by alpha patient
D SET^PSXSYS
;Clear 550.1
; of entries
K DIK,DA S DIK="^PSX(550.1,",DA=0 F S DA=$O(^PSX(550.1,DA)) Q:DA'>0 D ^DIK
; walk down the PTNM,DFN,RX,FILL 'C' index of PSX(550.2,PSXBAT,15,'C' - RX multiple
; Alpha order by patient name
S PSXNM="",ZCNT=0,PSXMSG=0 ;PSXMSG now starts at 1 every batch incremented in NEWMSG^PSXRXQU
S PSSWSITE=+$O(^PS(59.7,0))
F S PSXNM=$O(^PSX(550.2,PSXBAT,15,"C",PSXNM)) Q:PSXNM']"" D
. S DFN="" F S DFN=$O(^PSX(550.2,PSXBAT,15,"C",PSXNM,DFN)) Q:DFN'>0 D
.. S MSG=0 K PSX,PSXORD
.. D NEWMSG^PSXRXQU,ORD,MRX^PSXBLD1,LOADMSG^PSXRXQU
D DIV^PSXBLD1 ;build NTE1
K MSG,PSXNM,DFN,RX,RXF,REG,PSCAP,X,Y,PSXPTR,PSSWSITE
Q
ORD ; PSXMSG was returned by call to NEWMSG^PSXRXQU
; Loop RXs, RXFs in Transmission PSXBAT
;S REG=$S($P($G(^PS(55,DFN,0)),"^",3)=1:1,1:""),PSCAP=+$P($G(^PS(55,DFN,0)),"^",2)
S RX=0 K RXY,RXY1
S RX=0 F S RX=$O(^PSX(550.2,PSXBAT,15,"C",PSXNM,DFN,RX)) Q:RX'>0 D
. S REG=$S($P($G(^PS(55,DFN,0)),"^",3)=1:1,1:""),PSCAP=+$P($G(^PS(55,DFN,0)),"^",2) ;moved down p98
. S REC=$O(^PS(52.5,"B",RX,0))
. I 'REC D DEL5502 Q ;RX was removed from 52.5 during transmission
. I $$GET1^DIQ(52,RX,100.2,"I")]"" S REG=$S($$GET1^DIQ(52,RX,100.2,"I")=1:1,1:"") ;p98
. S RXY=^PSRX(RX,0),RXF=$O(^PSX(550.2,PSXBAT,15,"C",PSXNM,DFN,RX,0))
. S PTR=RX S:RXF>0 RXY1=$G(^PSRX(RX,1,RXF,0)) D ORC ;builds RX HL7 segments into PSXORD(
. I PSXFLAG=1 S ^PS(52.5,REC,"P")=1,^PS(52.5,"ADL",DT,REC)="" ;update print node
. D RXMSG^PSXRXQU ;put RX,RXF into PSXMSG 550.1 RX multiple ; returns PSXRXMDA
. ;D FILE^PSXRXU ;update 52 & 52.5
. I PSXFLAG=1 D EN^PSOHLSN1(RX,"SC","ZU","Transmitted to CMOP","")
K PSCLN,ZDU,FDT,DRUG,RXN,WARN,TECH,QTY,PHYS,DAYS,LSTFIL,COPAY,DEA,P,PTST,REF,VRPH,RXY,RXY1
Q
ORC ;builds RX HL7 segments into PSXORD(
Q:($G(RXF)>0&($G(RXY1)=""))
N PSOLBLCP
S PSX(RX)=RXF,MSG=MSG+1,FDT=$P(^PSRX(RX,2),"^",2),PSXORD(MSG)="ORC|NW|"
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)
D COPAYCK ; DO ADDITIONAL CHECKS TO DETERMINE CURRENT COPAY STATUS
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
I '$D(PSSWSITE) S PSSWSITE=+$O(^PS(59.7,0))
I $P($G(^PS(59.7,PSSWSITE,10)),"^",10)="N" D
.S WARN=$$DRUG^PSSWRNA(+$P(RXY,"^",6),DFN)
I $G(DRUG) S ZDU=$P($G(^PSDRUG(DRUG,660)),"^",8)
S ISD=$P(RXY,"^",13),ISD=ISD+17000000
G:RXF>0 REF
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)
S ZFIL=$G(^PSRX(RX,3))
S LSTFIL=$S(+$P(ZFIL,"^",4):$P(ZFIL,"^",4),1:+$P(ZFIL,"^"))
S LSTFIL=LSTFIL+17000000
S EXPDT=$P(^PSRX(RX,2),U,6) S:+EXPDT EXPDT=EXPDT+17000000
G RX1
REF ;
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)
S FDT=$P(RXY1,"^")
S ZFIL=$G(^PSRX(RX,3))
S LSTFIL=$S(+$P(ZFIL,"^",4):$P(ZFIL,"^",4),1:+$P(ZFIL,"^"))
S LSTFIL=LSTFIL+17000000
S EXPDT=$P(^PSRX(RX,2),"^",6),EXPDT=EXPDT+17000000
RX1 ;
S X="RX1|",$P(X,"|",13)=QTY,$P(X,"|",21)=ISD,$P(X,"|",25)=EXPDT
S $P(X,"|",2)=+$P(PSXSYS,"^",2)_"-"_$P(RXY,"^")_"-"_(RXF+1)
S Y1=$P($G(^PSDRUG($P(RXY,"^",6),"ND")),U,3)
D DGST
S $P(X,"|",15)=$S($L($G(PSXDGST)):PSXDGST_"^L",1:"^^L")
S $P(X,"|",20)=$P(RXY,"^",9),$P(X,"|",22)=+$P(RXY,"^",9)-RXF
S $P(X,"|",26)=LSTFIL,$P(X,"|",27)=$P(RXY,"^")
K ZFIL S MSG=MSG+1,PSXORD(MSG)=X_"||||",FLG=0 D SIG K MAX,FLG,X
ZX1 ;
S REFDIV=$S($P($G(^PS(59.7,1,40.1)),"^",4):$P(^(40.1),"^",4),1:PSOSITE)
S X="ZX1|"_$P(RXY,"^")_"|"_$P($G(^PS(59,REFDIV,0)),"^",6)_"^"_$P($G(^(0)),"^")_"|M|"
K REFDIV
; Count number of CMOP rxs for this patient order
S Y=1,Y1=RX F S Y1=$O(^TMP($J,"PSX",PSXNM,DFN,Y1)) Q:'Y1 S Y=Y+1
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
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)="(***/***)"
I '+$G(PSOINST) D:'+$G(PSXSYS) SET^PSXSYS S PSOINST=+$P(PSXSYS,"^",2)
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
;Addition for CS transmissions...1 if CS, "" if not...
S PSXCSB=$P(^PSRX(RX,0),"^",6),PSXCSC=$P($G(^PSDRUG(PSXCSB,0)),"^",3)
F PSXCSD=3:1:5 I PSXCSC[PSXCSD S PSXCSRX=1
S $P(X,"|",15)=$G(PSXCSRX) K PSXCSRX,PSXCSC,PSXCSB,PSXCSD
D WARN
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
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)
;
K RNEW,SIG,SGY,ISD,EXPDT
S MSG=MSG+1,PSXORD(MSG)=X
S PSSWSITE=+$O(^PS(59.7,0))
I $P($G(^PS(59.7,PSSWSITE,10)),"^",10)="N" D NEWWARN^PSXBLD2
Q
A 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)
I (+$G(FLG)=0)&(($L(SGY)+$L(X))'>70) S SGY=SGY_X_" " Q
I (+$G(FLG)=1)&(($L(SGY)+$L(X))'>100) S SGY=SGY_X_" " Q
I $G(FLG)=1 S MSG=MSG+1,PSXORD(MSG)=$TR("NTE|7||"_SGY,"\","/"),SGY=X_" " Q
S PSXORD(MSG)=$TR(PSXORD(MSG)_SGY,"\","/"),SGY=X_" ",FLG=1
Q
SIG ;
G:($P(^PSRX(RX,"SIG"),"^",2)=1) EXPAND
S SIG=$P(^PSRX(RX,"SIG"),"^")
S SGY="" F P=1:1:$L(SIG," ") S X=$P(SIG," ",P) D A:X]""
I SGY]"",FLG=0 S PSXORD(MSG)=$TR(PSXORD(MSG)_SGY,"\","/")
I SGY]"",FLG=1 S MSG=MSG+1,PSXORD(MSG)=$TR("NTE|7||"_SGY,"\","/")
I $D(^DPT(DFN,"NHC")),^("NHC")="Y" S MSG=MSG+1,PSXORD(MSG)=$TR("NTE|7||Exp:______ Mfg:______","\","/")
K SIG,%,J,Z,SGY,X
Q
STRIP ;strip out any HL7 delimiters
F %="|","~","^","\" F Q:Y'[% S Y=$P(Y,%,1)_" "_$P(Y,%,2,999)
;replace "&" in sig with escape sequence "\T\"
;S:Y["&" Y=$P(Y,"&",1)_"\T\"_$P(Y,"&",2,999)
Q
EXPAND ;expands the sig
N NTESEQ
K ^UTILITY($J,"W") S DIWL=1,DIWR=80,DIWF="C80"
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
S YY=0 F S YY=$O(^UTILITY($J,"W",1,YY)) Q:YY'>0 D
.I YY=1 S NTESEQ=1,PSXORD(MSG)=$TR($G(PSXORD(MSG))_$G(^(YY,0)),"\","/") Q
.S MSG=$G(MSG)+1,PSXORD(MSG)=$TR("NTE|7||"_$G(^(YY,0)),"\","/") D
..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
.Q
K XX,YY,DIWL,DIWR,DIWF,X,Y,^UTILITY($J,"W"),Z
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
.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
S NTESEQ=1
S DIWL=1,DIWR=80,DIWF="C80",(XX,YY)=0
F S XX=$O(SIG2(XX)) Q:'XX S X=SIG2(XX) S Y=X D STRIP S X=Y D ^DIWP
S PSSWSITE=+$O(^PS(59.7,0))
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
.S PSXORD(MSG)=$P(PSXORD(MSG),"|",1,2)_"|"_$P(RXY,"^")_"|SPA|"_NTESEQ_"|"_$P(PSXORD(MSG),"|",4,99),NTESEQ=NTESEQ+1
K XX,YY,DIWL,DIWR,DIWF,X,Y,^UTILITY($J,"W"),SIG2,PSSWSITE
Q
DGST ; returns PSXDGST
N RXNUM,RXEX,PTRA,PTRB,ZX,PSXPTR
S PSXPTR=RX K PSXDGST
S RXNUM=$P($G(^PSRX(PSXPTR,0)),"^",6),RXEX=$P($G(^PSRX(PSXPTR,0)),"^",1)
I $G(^PSDRUG(RXNUM,"ND"))'="" D
.S PTRA=$P($G(^PSDRUG(RXNUM,"ND")),U,1),PTRB=$P($G(^PSDRUG(RXNUM,"ND")),U,3)
.I $G(PTRA)'="" S ZX=$$PROD2^PSNAPIS(PTRA,PTRB),DRUGCHK=$P($G(ZX),"^",3)
S:$G(DRUGCHK)'="" PSXDGST=$P(ZX,"^",2)_"^"_$P(ZX,"^")
Q
COPAYCK ; RECHECK COPAY STATUS FOR EACH FILL
N PSOLBLPS,PSOLBLDR,PSODBQ,PSOQI
S PSOLBLPS=+$P(RXY,"^",3),PSOLBLDR=+$P(RXY,"^",6)
I $P($G(^PS(53,+$G(PSOLBLPS),0)),"^",7) S COPAY="" Q
I $P($G(^PSDRUG(+$G(PSOLBLDR),0)),"^",3)["I"!($P($G(^(0)),"^",3)["S") S COPAY="" Q
S PSOQI=$G(^PSRX(RX,"IBQ"))
I PSOQI["1" S COPAY="" Q
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)
I $G(PSOLBLCP)=0 S COPAY="" Q
I $G(PSOLBLCP)=2,'$P($G(^PSRX(RX,"IB")),"^") S COPAY="" Q
S COPAY=1
Q
;
DEL5502 ; RX was removed from 52.5 during transmission
N DA,DIK
S DA=$O(^PSX(550.2,PSXBAT,15,"B",RX,0))
S DA(1)=PSXBAT,DIK="^PSX(550.2,"_DA(1)_",15," D ^DIK
Q
WARN ;
I '$D(PSSWSITE) S PSSWSITE=+$O(^PS(59.7,0))
I $P($G(^PS(59.7,PSSWSITE,10)),"^",10)="N" Q
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
S:+W1>0 $P(X,"|",17)=W1 K WARN,J,W,L,W1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXBLD 9912 printed Oct 16, 2024@17:44:19 Page 2
PSXBLD ;BIR/BAB-Build HL7 Data for CMOP Rx Queue ;24 Jun 2002 5:19 PM
+1 ;;2.0;CMOP;**3,23,29,28,43,41,50,54,98**;11 Apr 97;Build 5
+2 ;
+3 ;Reference to ^PSRX( supported by DBIA #1977
+4 ;Reference to ^PSDRUG( supported by DBIA #1983
+5 ;Reference to ^PS(51, supported by DBIA #1980
+6 ;Reference to ^PS(52.5 supported by DBIA #1978
+7 ;Reference to ^PS(53, supported by DBIA #1975
+8 ;Reference to ^PS(55, supported by DBIA #2228
+9 ;Reference to ^PS(59, supported by DBIA #1976
+10 ;Reference to ^PS(59.7, supported by DBIA #694
+11 ;Reference to ^DPT( supported by DBIA #3097
+12 ;Reference to ^PSRX( supported by DBIA #1977
+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
EN ; build entries into 550.1 by alpha patient
+1 DO SET^PSXSYS
+2 ;Clear 550.1
+3 ; of entries
+4 KILL DIK,DA
SET DIK="^PSX(550.1,"
SET DA=0
FOR
SET DA=$ORDER(^PSX(550.1,DA))
if DA'>0
QUIT
DO ^DIK
+5 ; walk down the PTNM,DFN,RX,FILL 'C' index of PSX(550.2,PSXBAT,15,'C' - RX multiple
+6 ; Alpha order by patient name
+7 ;PSXMSG now starts at 1 every batch incremented in NEWMSG^PSXRXQU
SET PSXNM=""
SET ZCNT=0
SET PSXMSG=0
+8 SET PSSWSITE=+$ORDER(^PS(59.7,0))
+9 FOR
SET PSXNM=$ORDER(^PSX(550.2,PSXBAT,15,"C",PSXNM))
if PSXNM']""
QUIT
Begin DoDot:1
+10 SET DFN=""
FOR
SET DFN=$ORDER(^PSX(550.2,PSXBAT,15,"C",PSXNM,DFN))
if DFN'>0
QUIT
Begin DoDot:2
+11 SET MSG=0
KILL PSX,PSXORD
+12 DO NEWMSG^PSXRXQU
DO ORD
DO MRX^PSXBLD1
DO LOADMSG^PSXRXQU
End DoDot:2
End DoDot:1
+13 ;build NTE1
DO DIV^PSXBLD1
+14 KILL MSG,PSXNM,DFN,RX,RXF,REG,PSCAP,X,Y,PSXPTR,PSSWSITE
+15 QUIT
ORD ; PSXMSG was returned by call to NEWMSG^PSXRXQU
+1 ; Loop RXs, RXFs in Transmission PSXBAT
+2 ;S REG=$S($P($G(^PS(55,DFN,0)),"^",3)=1:1,1:""),PSCAP=+$P($G(^PS(55,DFN,0)),"^",2)
+3 SET RX=0
KILL RXY,RXY1
+4 SET RX=0
FOR
SET RX=$ORDER(^PSX(550.2,PSXBAT,15,"C",PSXNM,DFN,RX))
if RX'>0
QUIT
Begin DoDot:1
+5 ;moved down p98
SET REG=$SELECT($PIECE($GET(^PS(55,DFN,0)),"^",3)=1:1,1:"")
SET PSCAP=+$PIECE($GET(^PS(55,DFN,0)),"^",2)
+6 SET REC=$ORDER(^PS(52.5,"B",RX,0))
+7 ;RX was removed from 52.5 during transmission
IF 'REC
DO DEL5502
QUIT
+8 ;p98
IF $$GET1^DIQ(52,RX,100.2,"I")]""
SET REG=$SELECT($$GET1^DIQ(52,RX,100.2,"I")=1:1,1:"")
+9 SET RXY=^PSRX(RX,0)
SET RXF=$ORDER(^PSX(550.2,PSXBAT,15,"C",PSXNM,DFN,RX,0))
+10 ;builds RX HL7 segments into PSXORD(
SET PTR=RX
if RXF>0
SET RXY1=$GET(^PSRX(RX,1,RXF,0))
DO ORC
+11 ;update print node
IF PSXFLAG=1
SET ^PS(52.5,REC,"P")=1
SET ^PS(52.5,"ADL",DT,REC)=""
+12 ;put RX,RXF into PSXMSG 550.1 RX multiple ; returns PSXRXMDA
DO RXMSG^PSXRXQU
+13 ;D FILE^PSXRXU ;update 52 & 52.5
+14 IF PSXFLAG=1
DO EN^PSOHLSN1(RX,"SC","ZU","Transmitted to CMOP","")
End DoDot:1
+15 KILL PSCLN,ZDU,FDT,DRUG,RXN,WARN,TECH,QTY,PHYS,DAYS,LSTFIL,COPAY,DEA,P,PTST,REF,VRPH,RXY,RXY1
+16 QUIT
ORC ;builds RX HL7 segments into PSXORD(
+1 if ($GET(RXF)>0&($GET(RXY1)=""))
QUIT
+2 NEW PSOLBLCP
+3 SET PSX(RX)=RXF
SET MSG=MSG+1
SET FDT=$PIECE(^PSRX(RX,2),"^",2)
SET PSXORD(MSG)="ORC|NW|"
+4 SET X=+$GET(^PSRX(RX,"IB"))
SET COPAY=$SELECT(X=1:1,X=2:1,1:"")
KILL X
SET RXN=$PIECE(RXY,"^")
SET VRPH=$PIECE($GET(^PSRX(RX,2)),"^",10)
+5 ; DO ADDITIONAL CHECKS TO DETERMINE CURRENT COPAY STATUS
DO COPAYCK
+6 SET (DRUG,WARN,DEA)=""
IF $DATA(^PSDRUG(+$PIECE(RXY,"^",6),0))
SET DRUG=$PIECE(^(0),"^")
SET WARN=$PIECE(^(0),"^",8)
SET DEA=$PIECE(^(0),"^",3)
SET Y=DRUG
DO STRIP
SET DRUG=Y
KILL Y
+7 IF '$DATA(PSSWSITE)
SET PSSWSITE=+$ORDER(^PS(59.7,0))
+8 IF $PIECE($GET(^PS(59.7,PSSWSITE,10)),"^",10)="N"
Begin DoDot:1
+9 SET WARN=$$DRUG^PSSWRNA(+$PIECE(RXY,"^",6),DFN)
End DoDot:1
+10 IF $GET(DRUG)
SET ZDU=$PIECE($GET(^PSDRUG(DRUG,660)),"^",8)
+11 SET ISD=$PIECE(RXY,"^",13)
SET ISD=ISD+17000000
+12 if RXF>0
GOTO REF
+13 SET TECH=+$PIECE(RXY,"^",16)
SET QTY=$PIECE(RXY,"^",7)
SET PHYS=$SELECT($DATA(^VA(200,+$PIECE(RXY,"^",4),0)):$PIECE(^(0),"^"),1:"UNKNOWN")
SET DAYS=$PIECE(RXY,"^",8)
+14 SET ZFIL=$GET(^PSRX(RX,3))
+15 SET LSTFIL=$SELECT(+$PIECE(ZFIL,"^",4):$PIECE(ZFIL,"^",4),1:+$PIECE(ZFIL,"^"))
+16 SET LSTFIL=LSTFIL+17000000
+17 SET EXPDT=$PIECE(^PSRX(RX,2),U,6)
if +EXPDT
SET EXPDT=EXPDT+17000000
+18 GOTO RX1
REF ;
+1 SET TECH=+$PIECE(RXY1,"^",7)
SET QTY=$PIECE(RXY1,"^",4)
SET PHYS=$SELECT($DATA(^VA(200,+$PIECE(RXY1,"^",17),0)):$PIECE(^(0),"^"),1:"UNKNOWN")
SET DAYS=$PIECE(RXY1,"^",10)
+2 SET FDT=$PIECE(RXY1,"^")
+3 SET ZFIL=$GET(^PSRX(RX,3))
+4 SET LSTFIL=$SELECT(+$PIECE(ZFIL,"^",4):$PIECE(ZFIL,"^",4),1:+$PIECE(ZFIL,"^"))
+5 SET LSTFIL=LSTFIL+17000000
+6 SET EXPDT=$PIECE(^PSRX(RX,2),"^",6)
SET EXPDT=EXPDT+17000000
RX1 ;
+1 SET X="RX1|"
SET $PIECE(X,"|",13)=QTY
SET $PIECE(X,"|",21)=ISD
SET $PIECE(X,"|",25)=EXPDT
+2 SET $PIECE(X,"|",2)=+$PIECE(PSXSYS,"^",2)_"-"_$PIECE(RXY,"^")_"-"_(RXF+1)
+3 SET Y1=$PIECE($GET(^PSDRUG($PIECE(RXY,"^",6),"ND")),U,3)
+4 DO DGST
+5 SET $PIECE(X,"|",15)=$SELECT($LENGTH($GET(PSXDGST)):PSXDGST_"^L",1:"^^L")
+6 SET $PIECE(X,"|",20)=$PIECE(RXY,"^",9)
SET $PIECE(X,"|",22)=+$PIECE(RXY,"^",9)-RXF
+7 SET $PIECE(X,"|",26)=LSTFIL
SET $PIECE(X,"|",27)=$PIECE(RXY,"^")
+8 KILL ZFIL
SET MSG=MSG+1
SET PSXORD(MSG)=X_"||||"
SET FLG=0
DO SIG
KILL MAX,FLG,X
ZX1 ;
+1 SET REFDIV=$SELECT($PIECE($GET(^PS(59.7,1,40.1)),"^",4):$PIECE(^(40.1),"^",4),1:PSOSITE)
+2 SET X="ZX1|"_$PIECE(RXY,"^")_"|"_$PIECE($GET(^PS(59,REFDIV,0)),"^",6)_"^"_$PIECE($GET(^(0)),"^")_"|M|"
+3 KILL REFDIV
+4 ; Count number of CMOP rxs for this patient order
+5 SET Y=1
SET Y1=RX
FOR
SET Y1=$ORDER(^TMP($JOB,"PSX",PSXNM,DFN,Y1))
if 'Y1
QUIT
SET Y=Y+1
+6 SET $PIECE(X,"|",5)=Y
SET $PIECE(X,"|",6)="("_(RXF+1)_"of"_(1+$PIECE(RXY,"^",9))_")"
SET $PIECE(X,"|",8)=REG
KILL Y,Y1
SET $PIECE(X,"|",7)=$SELECT($DATA(^VA(200,+$PIECE(^PSRX(RX,0),"^",4),0)):$EXTRACT($PIECE(^(0),"^",1),1,20),1:"UNKNOWN")
SET $PIECE(X,"|",8)=REG
KILL Y,Y1
+7 SET VRPH=$PIECE(^PSRX(RX,2),"^",10)
SET $PIECE(X,"|",9)="("_$GET(TECH)_"/"_$SELECT($DATA(VRPH):VRPH,1:" ")_")"
if $LENGTH($PIECE(X,"|",9))>12
SET $PIECE(X,"|",9)="(***/***)"
+8 IF '+$GET(PSOINST)
if '+$GET(PSXSYS)
DO SET^PSXSYS
SET PSOINST=+$PIECE(PSXSYS,"^",2)
+9 SET $PIECE(X,"|",10)=1700+$EXTRACT(FDT,1,3)_$EXTRACT(FDT,4,7)
SET $PIECE(X,"|",11)=COPAY
SET $PIECE(X,"|",13)=PSCAP
SET $PIECE(X,"|",14)=DAYS
SET $PIECE(X,"|",16)=PSOINST_"-"_RX
+10 ;Addition for CS transmissions...1 if CS, "" if not...
+11 SET PSXCSB=$PIECE(^PSRX(RX,0),"^",6)
SET PSXCSC=$PIECE($GET(^PSDRUG(PSXCSB,0)),"^",3)
+12 FOR PSXCSD=3:1:5
IF PSXCSC[PSXCSD
SET PSXCSRX=1
+13 SET $PIECE(X,"|",15)=$GET(PSXCSRX)
KILL PSXCSRX,PSXCSC,PSXCSB,PSXCSD
+14 DO WARN
+15 SET PTST=$GET(^PS(53,$PIECE(RXY,"^",3),0))
SET RNEW=1
SET REF=+$PIECE(^PSRX(RX,0),"^",9)-RXF
if REF<0
SET REF=0
IF REF=0
if ('$PIECE(PTST,"^",5))!(DEA["A"&(DEA'["B"))!(DEA["W")
SET RNEW=0
+16 SET $PIECE(X,"|",12)=RNEW
SET PTST=$PIECE(PTST,"^",2)
SET PSCLN=+$PIECE(RXY,"^",5)
SET PSCLN=$SELECT($DATA(^SC(PSCLN,0)):$PIECE(^(0),"^",1),1:"UNKNOWN")
SET $PIECE(X,"|",18)=$EXTRACT((PTST),1,20)
SET $PIECE(X,"|",19)=$EXTRACT(PSCLN,1,20)
+17 ;
+18 KILL RNEW,SIG,SGY,ISD,EXPDT
+19 SET MSG=MSG+1
SET PSXORD(MSG)=X
+20 SET PSSWSITE=+$ORDER(^PS(59.7,0))
+21 IF $PIECE($GET(^PS(59.7,PSSWSITE,10)),"^",10)="N"
DO NEWWARN^PSXBLD2
+22 QUIT
A IF $DATA(^PS(51,"A",X))
SET %=^(X)
SET X=$PIECE(%,"^",1)
IF $PIECE(%,"^",2)'=""
SET Y=$PIECE(SIG," ",P-1)
SET Y=$EXTRACT(Y,$LENGTH(Y))
if Y>1
SET X=$PIECE(%,"^",2)
+1 IF (+$GET(FLG)=0)&(($LENGTH(SGY)+$LENGTH(X))'>70)
SET SGY=SGY_X_" "
QUIT
+2 IF (+$GET(FLG)=1)&(($LENGTH(SGY)+$LENGTH(X))'>100)
SET SGY=SGY_X_" "
QUIT
+3 IF $GET(FLG)=1
SET MSG=MSG+1
SET PSXORD(MSG)=$TRANSLATE("NTE|7||"_SGY,"\","/")
SET SGY=X_" "
QUIT
+4 SET PSXORD(MSG)=$TRANSLATE(PSXORD(MSG)_SGY,"\","/")
SET SGY=X_" "
SET FLG=1
+5 QUIT
SIG ;
+1 if ($PIECE(^PSRX(RX,"SIG"),"^",2)=1)
GOTO EXPAND
+2 SET SIG=$PIECE(^PSRX(RX,"SIG"),"^")
+3 SET SGY=""
FOR P=1:1:$LENGTH(SIG," ")
SET X=$PIECE(SIG," ",P)
if X]""
DO A
+4 IF SGY]""
IF FLG=0
SET PSXORD(MSG)=$TRANSLATE(PSXORD(MSG)_SGY,"\","/")
+5 IF SGY]""
IF FLG=1
SET MSG=MSG+1
SET PSXORD(MSG)=$TRANSLATE("NTE|7||"_SGY,"\","/")
+6 IF $DATA(^DPT(DFN,"NHC"))
IF ^("NHC")="Y"
SET MSG=MSG+1
SET PSXORD(MSG)=$TRANSLATE("NTE|7||Exp:______ Mfg:______","\","/")
+7 KILL SIG,%,J,Z,SGY,X
+8 QUIT
STRIP ;strip out any HL7 delimiters
+1 FOR %="|","~","^","\"
FOR
if Y'[%
QUIT
SET Y=$PIECE(Y,%,1)_" "_$PIECE(Y,%,2,999)
+2 ;replace "&" in sig with escape sequence "\T\"
+3 ;S:Y["&" Y=$P(Y,"&",1)_"\T\"_$P(Y,"&",2,999)
+4 QUIT
EXPAND ;expands the sig
+1 NEW NTESEQ
+2 KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=80
SET DIWF="C80"
+3 SET XX=0
FOR
SET XX=$ORDER(^PSRX(RX,"SIG1",XX))
if XX'>0
QUIT
SET X=^(XX,0)
SET Y=X
DO STRIP
SET X=Y
DO ^DIWP
+4 SET YY=0
FOR
SET YY=$ORDER(^UTILITY($JOB,"W",1,YY))
if YY'>0
QUIT
Begin DoDot:1
+5 IF YY=1
SET NTESEQ=1
SET PSXORD(MSG)=$TRANSLATE($GET(PSXORD(MSG))_$GET(^(YY,0)),"\","/")
QUIT
+6 SET MSG=$GET(MSG)+1
SET PSXORD(MSG)=$TRANSLATE("NTE|7||"_$GET(^(YY,0)),"\","/")
Begin DoDot:2
+7 IF $PIECE($GET(^PS(59.7,PSSWSITE,10)),"^",10)="N"
SET PSXORD(MSG)=$PIECE(PSXORD(MSG),"|",1,2)_"|"_$PIECE(RXY,"^")_"|ENG|"_NTESEQ_"|"_$PIECE(PSXORD(MSG),"|",4,99)
SET NTESEQ=NTESEQ+1
End DoDot:2
+8 QUIT
End DoDot:1
+9 KILL XX,YY,DIWL,DIWR,DIWF,X,Y,^UTILITY($JOB,"W"),Z
+10 ;ONLY SEND SPANISH SIG IF PMI PREF (ON PID SEGMENT) IS ALSO SPANISH
IF $$PATCH^XPDUTL("PSO*7.0*117")
IF $PIECE($GET(^PS(55,DFN,"LAN")),"^",1)
IF $PIECE($GET(^PS(55,DFN,"LAN")),"^",2)=2
DO OTHL1^PSOLBL3(RX)
Begin DoDot:1
+11 ; IF LAST ENTRY IS NULL, REMOVE IT
SET XX=0
FOR
SET XX=$ORDER(SIG2(XX))
if 'XX
QUIT
IF $ORDER(SIG2(XX))=""
IF SIG2(XX)=""
KILL SIG2(XX)
QUIT
End DoDot:1
if '$ORDER(SIG2(0))
QUIT
+12 SET NTESEQ=1
+13 SET DIWL=1
SET DIWR=80
SET DIWF="C80"
SET (XX,YY)=0
+14 FOR
SET XX=$ORDER(SIG2(XX))
if 'XX
QUIT
SET X=SIG2(XX)
SET Y=X
DO STRIP
SET X=Y
DO ^DIWP
+15 SET PSSWSITE=+$ORDER(^PS(59.7,0))
+16 FOR
SET YY=$ORDER(^UTILITY($JOB,"W",1,YY))
if YY'>0
QUIT
SET MSG=$GET(MSG)+1
SET PSXORD(MSG)=$TRANSLATE("NTE|7||"_$GET(^(YY,0)),"\","/")
IF $PIECE($GET(^PS(59.7,PSSWSITE,10)),"^",10)="N"
Begin DoDot:1
+17 SET PSXORD(MSG)=$PIECE(PSXORD(MSG),"|",1,2)_"|"_$PIECE(RXY,"^")_"|SPA|"_NTESEQ_"|"_$PIECE(PSXORD(MSG),"|",4,99)
SET NTESEQ=NTESEQ+1
End DoDot:1
+18 KILL XX,YY,DIWL,DIWR,DIWF,X,Y,^UTILITY($JOB,"W"),SIG2,PSSWSITE
+19 QUIT
DGST ; returns PSXDGST
+1 NEW RXNUM,RXEX,PTRA,PTRB,ZX,PSXPTR
+2 SET PSXPTR=RX
KILL PSXDGST
+3 SET RXNUM=$PIECE($GET(^PSRX(PSXPTR,0)),"^",6)
SET RXEX=$PIECE($GET(^PSRX(PSXPTR,0)),"^",1)
+4 IF $GET(^PSDRUG(RXNUM,"ND"))'=""
Begin DoDot:1
+5 SET PTRA=$PIECE($GET(^PSDRUG(RXNUM,"ND")),U,1)
SET PTRB=$PIECE($GET(^PSDRUG(RXNUM,"ND")),U,3)
+6 IF $GET(PTRA)'=""
SET ZX=$$PROD2^PSNAPIS(PTRA,PTRB)
SET DRUGCHK=$PIECE($GET(ZX),"^",3)
End DoDot:1
+7 if $GET(DRUGCHK)'=""
SET PSXDGST=$PIECE(ZX,"^",2)_"^"_$PIECE(ZX,"^")
+8 QUIT
COPAYCK ; RECHECK COPAY STATUS FOR EACH FILL
+1 NEW PSOLBLPS,PSOLBLDR,PSODBQ,PSOQI
+2 SET PSOLBLPS=+$PIECE(RXY,"^",3)
SET PSOLBLDR=+$PIECE(RXY,"^",6)
+3 IF $PIECE($GET(^PS(53,+$GET(PSOLBLPS),0)),"^",7)
SET COPAY=""
QUIT
+4 IF $PIECE($GET(^PSDRUG(+$GET(PSOLBLDR),0)),"^",3)["I"!($PIECE($GET(^(0)),"^",3)["S")
SET COPAY=""
QUIT
+5 SET PSOQI=$GET(^PSRX(RX,"IBQ"))
+6 IF PSOQI["1"
SET COPAY=""
QUIT
+7 ; CHECK WHETHER EXEMPT (SC OR INCOME EXEMPT - OR IF SERVICE-CONNECTED QUESTION NEEDS TO BE ASKED KEEP COPAY AS IT WAS)
IF $GET(PSOLBLCP)=""
DO IBCP^PSOLBL
+8 IF $GET(PSOLBLCP)=0
SET COPAY=""
QUIT
+9 IF $GET(PSOLBLCP)=2
IF '$PIECE($GET(^PSRX(RX,"IB")),"^")
SET COPAY=""
QUIT
+10 SET COPAY=1
+11 QUIT
+12 ;
DEL5502 ; RX was removed from 52.5 during transmission
+1 NEW DA,DIK
+2 SET DA=$ORDER(^PSX(550.2,PSXBAT,15,"B",RX,0))
+3 SET DA(1)=PSXBAT
SET DIK="^PSX(550.2,"_DA(1)_",15,"
DO ^DIK
+4 QUIT
WARN ;
+1 IF '$DATA(PSSWSITE)
SET PSSWSITE=+$ORDER(^PS(59.7,0))
+2 IF $PIECE($GET(^PS(59.7,PSSWSITE,10)),"^",10)="N"
QUIT
+3 SET L=+$LENGTH(WARN,",")
SET W1=""
FOR J=1:1:L
SET W=$PIECE(WARN,",",J)
IF +W>0
IF (+W'>20)
if +W1>0
SET W1=W1_"~"_W
if +W1=0
SET W1=W1_W
+4 if +W1>0
SET $PIECE(X,"|",17)=W1
KILL WARN,J,W,L,W1
+5 QUIT
