- 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 Jan 18, 2025@02:44:42 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