PSORLLLI ;AITC/BWF - ONEVA LASER LABELS INITIALIZATION ;10/06/16 9:28am
;;7.0;OUTPATIENT PHARMACY;**454,643,728**;DEC 1997;Build 5
;
;DBIAs PSDRUG-221, PS(55-2228, SC-10040, IBARX-125, PSXSRP-2201, %ZIS-3435, DPT-3097, ^TMP($J,"PSNPPIO"-3794
;External reference to DRUG^PSSWRNA supported by DBIA 4449
;External reference to $$DS^PSSDSAPI supported by DBIA 5425
;External reference to ^DIC(5 supported by DBIA 4293
;External reference to ^SC( supported by DBIA 2675
;External reference to $$DS^PSSDSAPI supported by DBIA 5425
;External reference to ^ORD(101 supported by DBIA 872
;External reference to ^PS(51 supported by DBIA 2224
;External reference to ^PSNDF supported by DBIA 2195
;External reference to ^%ZIS(2 supported by DBIA 3435
;
;*244 remove test for partial fill when testing status > 11
;
DQ N PSOBIO,PSOXINT,PSOXMARK S (I,PSOIO)=0 F S I=$O(^%ZIS(2,IOST(0),55,I)) Q:'I S X0=$G(^(I,0)) I X0]"" S PSOIO($P(X0,"^"))=^(1),PSOIO=1
I '$G(PSOHLSV("PATCH INSTALLED FLAG"))!($G(PSOLONLY)) G DQS
S PSOXINT=$P($G(^PS(59,PSOSITE,1)),"^",30)
S PSOXMARK=0
S:+$G(PSOHLSV("L_DRUGIEN")) PSOXMARK=+$G(^PSDRUG(+PSOHLSV("L_DRUGIEN"),6))
I $S(PSOXINT=1:1,PSOXINT=2:1,PSOXINT=3:PSOXMARK,PSOXINT=4:PSOXMARK,1:0) D OPAI
I $S(PSOXINT=2:1,PSOXINT=3:PSOXMARK,1:0) G HLEX
DQS I '$D(^%ZIS(2,IOST(0),55,"B","LL")) G HLEX
DQ1 I '$D(RPPL) G HLEX
I $D(PSOIOS),PSOIOS]"" D DEVBAR^PSOBMST
K RRXFLX,RXFDAMG S PSOCKHN=","_$G(RPPL),PSRESOLV=+RPPL D CHECK
S PSOINT=1 F PI=1:1 S RX=$P(RPPL,",",PI) Q:RX="" D
.S PSOPDFN=$G(PSODFN),RXY=$G(RX0)
.K RXP,REPRINT D C
I 'PSOINT D TRAIL^PSORLLL1
;
HLEX K RXPI,PSORX,RXP,PSOIOS,PSOLAPPL,XXX,COPAYVAR,TECH,PHYS,MFG,NURSE,STATE,SIDE,COPIES,EXDT,ISD,PSOINST,RXN,RXY,VADT,DEA,WARN,FDT,QTY,PATST,PDA,PS,PS1,RXP,REPRINT
K SGY,OSGY,PS2,PSL,PSNP,INRX,RR,XTYPE,SSNP,SSNPN,PNM,ADDR,PSODBQ,PSOLASTF,PSRESOLV,PSOEXREP,PSOSXQ
K DATE,DR,DRUG,LINE,MW,PRTFL,VRPH,EXPDT,X2,DIFF,DAYS,PSZIP,PSOHZIP,PS55,PS55X,REF
K ^TMP($J,"PSNPMI"),^TMP($J,"PSOCP",+$G(PSOCPN)),PSOCPN,PSOLBLDR,PSOLBLPS,PSOLBLCP,RRXPR,RXRP,RXRS,PSOCKHN,RXFLX,PSOLAPPL,PSOPDFN,PSDFNFLG,PSOZERO,NEXTRX,PSOBLALL,STA
; NEW kill lines for cleanup - OneVA Pharmacy
K RX0,RX2,RX3,RXSTA,HINFO,RSIG,PSODFN,LOCDRUG,ROR1,RPAR0,RREF0,RFIEN,PARIEN,RIEN,PATST,RRFTYP,RRXFL,RRXPR,RSIG1,RPPL,HINFOST
K BOTTLBL,CONT,DOB,F8,FILLCONT,FLAG,JJ,L2,L3,L4,L5,LENGTH,MAILCOM,NOBARC,NOR,OFONT,OPSOX,OPSOY,ORS,OUT,PATSTIEN
K PFM,PI,PIMI,PLANNM,PMIM,PPHYS,PRCOPAY,PSCAP,PSCLN,PSDU,PSMP,PSOBY,PSOBYI,PSOCX,PSODFONT,PSODY,PSOFLAST,PSOFNOW
K PSOFONT,PSOFY,PSOHFONT,PSOINT,PSOLAN,PSONOW,PSONOWT,PSOQFONT,PSOQY,PSORYI,PSOSITE7,PSOSUREP,PSOSUSPR,PSOTFONT,X0,ZDRUG
K PSOTRAIL,PSOTY,PSOTYI,PSOYI,PSOYM,PTEXT,Q,EXP,PSLION,PSOBLRX,PSOHYI,PSOIO,SGC,SIG1,SIGDONE,SIGM,SS,ULN,VAADDR1,WARN5,ZY
I '$G(PSOSUREP),'$G(PSOSUSPR) D ^%ZISC S ZTREQ="@"
Q
;
C N PSOBIO S (I,PSOIO)=0 F S I=$O(^%ZIS(2,IOST(0),55,I)) Q:'I S X0=$G(^(I,0)) I X0]"" S PSOIO($P(X0,"^"))=^(1),PSOIO=1
U IO Q:'$D(RX0) S RXY=$G(RX0),RX2=$G(RX2),RXSTA=$G(RXSTA),RREF0=$G(RREF0),RPAR0=$G(RPAR0) K SGY,OSGY
S (SIGM,PFM,PMIM,L2,L3,L4,L5,FILLCONT,BOTTLBL)=0
K SIGF,PFF,PMIF S (SIGF,PFF,PMIF)=0 F I="DR","T" S (SIGF(I),PFF(I))=1
F I="A","B","I" S PMIF(I)=1
D NOW^%DTC S Y=$P(%,"."),PSOFNOW=% X ^DD("DD") S PSONOW=Y,Y=PSOFNOW X ^DD("DD") S PSONOWT=Y
S:$G(PSOBLALL) PSOBLRX=RX S:$D(RRXPR(RX)) RXP=RRXPR(RX)
S RXY=$G(RX0),RX2=$G(RX2),RXSTA=$G(RXSTA),RREF0=$G(RREF0),RPAR0=$G(RPAR0),ROR1=$G(ROR1),RSIG=$G(RSIG),RSIG1=$G(RSIG1)
K ^UTILITY("DIQ1",$J) S DA=$P($$SITE^VASITE(),"^")
I $G(DA) S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1 S PSOINST=$G(^UTILITY("DIQ1",$J,4,DA,99,"I")) K ^UTILITY("DIQ1",$J),DA,DR,DIC
S RXN=$P(RXY,"^"),DFN=$G(PSODFN),PSOLBLPS=+$P(RXY,"^",3),PSOLBLDR=+$G(LOCDRUG)
S ISD=$P(RXY,"^",13),RXF=0,SIG=$P($G(RSIG),"^"),ISD=$E(ISD,4,5)_"/"_$E(ISD,6,7)_"/"_($E(ISD,1,3)+1700),ZY=0,$P(LINE,"_",28)="_"
S NURSE=$S($P($G(^DPT(DFN,"NHC")),"^")="Y":1,$P($G(^PS(55,DFN,40)),"^"):1,1:0)
S FDT=$P(RX2,"^",2),PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:""),PS1=$S($D(^(1)):^(1),1:""),PSOSITE7=$P(^("IB"),"^")
S PS2=$P($G(HINFO),"^")_"^"_$P($G(HINFO),"^",4)
S EXPDT=$P(RX2,"^",6),EXDT=$S('EXPDT:"",1:$E(EXPDT,4,5)_"/"_$E(EXPDT,6,7)_"/"_($E(EXPDT,1,3)+1700))
S COPIES=$S($P(RXY,"^",18)]"":$P(RXY,"^",18),1:1)
K PSOCKHNX S PSOCKHL=$L(RX),PSOCKHN=$E($G(PSOCKHN),(PSOCKHL+2),999) D K PSOCKHNX,PSOCKHL,PSOCKHA
.S PSOCKHA=","_RX_","
.I PSOCKHN'[PSOCKHA Q
.S PSOCKHA=$E(PSOCKHA,1,($L(PSOCKHA)-1))
.S PSOCKHNX=$L(PSOCKHN,PSOCKHA)-1
.I +$G(PSOCKHNX)>0 D DOUB
I '$G(RXP) D OSET
I '$G(RXP) D G STA
. I '$G(RRXFL(RX)) S XTYPE=1 D REF
I $G(RXP) S XTYPE="P" D REF G STA
ORIG S TECH=$P(RXY,"^",16),PHYS=$S($P(RXY,"^",4)'="":$P(RXY,"^",4),1:"UKN")
S DAYS=$P(RXY,"^",8),QTY=$P(RXY,"^",7)
D 6^VADPT,PID^VADPT6 S SSNPN=""
STA ;
S HINFOST=$P($P(HINFO,U,2),"~",4)
S STATE=$S($G(HINFOST)'="":HINFOST,1:"UKN")
S DRUG=$$ZZ($G(LOCDRUG)),DEA=$P($G(^PSDRUG(+$G(LOCDRUG),0)),"^",3),WARN=$P($G(^(0)),"^",8)
S WARN=$$DRUG^PSSWRNA(+$G(LOCDRUG),+$G(DFN))
I $G(PARIEN) S RXPI=$G(PARIEN) D
.S RXP=$G(RPAR0)
.S RXY=$P(RXP,"^")_"^"_$P(RXY,"^",2,6)_"^"_$P(RXP,"^",4)_"^"_$P(RXP,"^",10)_"^"_$P(RXY,"^",9)_"^"_$P($G(RSIG),"^",2)_"^"_$P(RXP,"^",2)_"^"_$P(RXY,"^",12,14)_"^"_$P(RXSTA,"^")_"^"_$P(RXP,"^",7)_"^"_$P(RXY,"^",17,99)
.S FDT=$P(RXP,"^")
S MW=$P(RXY,"^",11) I $G(RRXFL(RX))'=0 D:$G(RRXFL(RX)) I '$G(RRXFL(RX)) S RXF=$P(RX0,"^",9) S:'$G(RXP) MW=$P(RREF0,"^",2) S FDT=+$G(RREF0)
.I $G(RRXFL(RX)),'$L(RREF0) K RRXFL(RX) Q
.;PSO*7*266
.S RXF=RRXFL(RX) S:'$G(RXP) MW=$P($G(RREF0),"^",2) S FDT=+$G(RREF0)
; always 'W' for oneva pharmacy
S MW="W"
;New mail codes for CMOP
S MAILCOM=""
S X=$G(^PS(55,DFN,0)),PSCAP=$P(X,"^",2),PS55=$P(X,"^",3),PS55X=$P(X,"^",5)
I PS55X]"",PS55>1,PS55X<DT S PS55=0
S MW=$S(MW="M":"REGULAR",MW="R":"CERTIFIED",1:"WINDOW")
I $G(PSMP(1))="",$G(PS55)=2 S PSMP(1)=$G(SSNPN)
S DATE=$E(FDT,1,7),REF=$P(RXY,"^",9) S:REF<1 REF=0 D PSOLBL2
S PSOLASTF=$P(RX3,"^")
S:$L(PSOLASTF) PSOLASTF=$E(PSOLASTF,4,5)_"/"_$E(PSOLASTF,6,7)_"/"_$E(PSOLASTF,2,3)
I '$L(PSOLASTF) S PSOLASTF="N/A"
S (X,PSOFLAST)=$G(PSOLASTF) I X?1N.E D ^%DT X ^DD("DD") S PSOFLAST=Y
S PATST=$G(PATST)
I PATST]"",$D(^PS(53,"C",PATST)) S PATSTIEN=$O(^PS(53,"C",PATST,0))
I $G(PATSTIEN) S PATST=$G(^PS(53,PATSTIEN,0))
S PRTFL=1 I REF=0 S:('$P(PATST,"^",5))!(DEA["W")!(DEA[1)!(DEA[2) PRTFL=0
S VRPH=$P(RX2,"^",10),PSCLN=$S($P($G(HINFO),U,5)]"":$P(HINFO,U,5),1:"OneVA")
S PATST=$P(PATST,"^",2),X1=DT,X2=$P(RXY,"^",8)-10 D C^%DTC:REF I $D(RX2),$P(RX2,"^",6),REF,X'<$P(RX2,"^",6) S REF=0,VRPH=$P(RX2,"^",10)
I $G(RXP) S COPAYVAR="" G LBL
I $P(RXSTA,"^")>0,$P(RXSTA,"^")'=2,'$G(PSODBQ) D SNO G LBL
LBL I $G(PSOIO("LLI"))]"" X PSOIO("LLI")
LBL2 S PSOINT=0 G ^PSORLLL1
REF S TECH=$S(XTYPE=1:$P($G(RREF0),"^",7),XTYPE="P":$P($G(RPAR0),"^",7),1:"UNKNOWN")
S QTY=$S(XTYPE=1:$P(RREF0,U,4),XTYPE="P":$P(RPAR0,U,4),1:"")
I XTYPE=1 S PHYS=$S($P($G(RREF0),"^",17)]"":$P($G(RREF0),"^",17),1:"UNKNOWN")
I XTYPE="P" S PHYS=$S($P($G(RPAR0),"^",17)]"":$P($G(RPAR0),"^",17),1:"UNKNOWN")
S DAYS=$S(XTYPE=1:$P(RREF0,U,10),XTYPE="P":$P(RPAR0,U,10),1:"")
Q
CHECK ; use DFN from ZTSAVE instead of from RX
S PSDFNFLG=0,PSOZERO=$P(RPPL,","),PSOPDFN=$G(DFN)
Q
OSET ;
N A
I $G(RRXFL(RX))']""!($G(RRXFL(RX))=0) D Q
.S A=$G(RX0)
.S TECH=$P(A,"^",16),QTY=$P(A,"^",7),PHYS=$S($P(A,"^",4)]"":$P(A,"^",4),1:"UKN") D 6^VADPT,PID^VADPT6 S SSNPN=""
.S DAYS=$P(A,"^",8)
I $G(RREF0)']"" K RRXFL(RX) Q
S A=$G(RREF0)
S TECH=$S($P(A,"^",7)]"":$P(A,"^",7),1:"UNKNOWN")
S QTY=$P(A,"^",4),PHYS=$S($P(A,"^",17)]"":$P(A,"^",17),1:"UNKNOWN") D 6^VADPT,PID^VADPT6 S SSNPN=""
S DAYS=$P(A,"^",10)
Q
DOUB ;
Q:'$D(RRXFL(RX))
I +$G(RRXFL(RX))-PSOCKHNX<0 Q
S RRXFLX(RX)=$G(RRXFL(RX))
S RRXFL(RX)=$G(RRXFL(RX))-PSOCKHNX
Q
SNO ;
S COPAYVAR="NO COPAY"
Q
ZZ(LDIEN) ; Returns VA print name, Trade Name, Generic Name
S I50=LDIEN,ZDRUG=$P(^PSDRUG(I50,0),U)
I $G(ZDRUG)']"" S ZDRUG="DRUG NOT ON FILE ("_I50_")" G END
I $D(^PSDRUG("AQ",I50)),($D(^PSDRUG(I50,"ND"))) D
.S Z1=$P($G(^PSDRUG(I50,"ND")),U),Z2=$P($G(^("ND")),U,3)
.I $G(Z1),($G(Z2)) D
..I $T(^PSNAPIS)]"" S PSOXN=$$PROD2^PSNAPIS(Z1,Z2) S ZDRUG=$P($G(PSOXN),"^") K PSOXN Q
..S ZDRUG=$P($G(^PSNDF(Z1,5,Z2,2)),"^")
.K Z1,Z2,I50
END K I50
Q ZDRUG
; copy of PSOLBL2 logic
PSOLBL2 ;
;I $P($G(SIG),"^",2) K SGY D PSOLBL3 G SIGOLD
I $P($G(RSIG),"^")]"" S SIG=$P($G(RSIG),"^") D SIG Q
S SIGDONE=0
F I=1:1 D Q:SIGDONE
.I '$D(RSIG1(I)) S SIGDONE=1 Q
.I '$L(SIG) S SIG=$G(RSIG1(I)) Q
.S SIG=$G(SIG)_" "_$G(RSIG1(I))
D SIG
QUIT K SIG,E,F,S Q
SIG K OT S SGY="" F P=1:1:$L(SIG," ") S X=$P(SIG," ",P) D:X]""
.I $D(^PS(51,"A",X)) D
..;PSO*7*282 Intended use
..I $P($G(^PS(55,DFN,"LAN")),"^") S OT=$O(^PS(51,"B",X,0)) I OT,$P($G(^PS(51,OT,0)),"^",4)<2,$P($G(^PS(51,OT,4)),"^")]"" S X=$P(^PS(51,OT,4),"^") K OT Q
..S %=^PS(51,"A",X),X=$P(%,"^") I $P(%,"^",2)]"" S Y=$P(SIG," ",P-1),Y=$E(Y,$L(Y)) S:Y>1 X=$P(%,"^",2)
.S SGY=SGY_X_" "
S X="",SGC=1 F J=1:1 S Z=$P(SGY," ",J) S:Z="" SGY(SGC)=X Q:Z="" S:$L(X)+$L(Z)'<$S($P(PSOPAR,"^",28):46,1:34) SGY(SGC)=X,SGC=SGC+1,X="" S X=X_Z_" "
SIGOLD I '$P(PSOPAR,"^",28) D K NHC
.K DIC,DR,DIQ,NHC S DIC=2,DA=DFN,DR=148,DIQ="NHC",DIQ(0)="I"
.D EN^DIQ1 K DIC,DR,DIQ
.I NHC(2,DFN,148,"I")="Y"!($P($G(^PS(55,DFN,40)),"^")) S SGC=SGC+1,SGY(SGC)="Expiration:________ Mfg:_________"
;
DPT S X=$S($D(^DPT(DFN,0))#2:^(0),1:""),DOB=$P(X,"^",3),L=$E(X,1)
S Y=$P(X,"^",9),PNM=$P(X,"^") D PID^VADPT S SS="",SSNP=""
I $P(PSOPAR,"^",28) K SIG,E,F,S Q
Q
;--- end PSOLBL2 LOGIC
PSOLBL3 ;
N CTCT,FFFF,LLIM,LLLL,LVAR,LVAR1,PPP,PPPP,SGCT,SIG9,OSIG,ZZZZ,PSLONG,PPPP
S PSLONG=$S($P(PSOPAR,"^",28):46,1:34)
; NEXT LINE IF SIG IS MOVED BACK TO MULTIPLE
S PPPP=1 F PPP=0:0 S PPP=$O(RSIG1(PPP)) Q:'PPP I $G(RSIG1(PPP))'="" S SIG9(PPPP)=$G(SIG1("SIG1",PPP)) S PPPP=PPPP+1
;NEXT LINE IF 1ST FRONT DOOR SIG LINE LIVES IN BACK DOOR SPOT
;S SIG9(1)=$P($G(^PSRX(RX,"SIG")),"^") S PPP=2 F PPPP=0:0 S PPPP=$O(^PSRX(RX,"SIG1",PPPP)) Q:'PPPP I $G(^(PPPP,0))'="" S SIG9(PPP)=$G(^(0)),PPP=PPP+1
FMSIG S (LVAR,LVAR1)="",LLLL=1
F FFFF=0:0 S FFFF=$O(SIG9(FFFF)) Q:'FFFF S SGCT=0 F ZZZZ=1:1:$L(SIG9(FFFF)) I $E(SIG9(FFFF),ZZZZ)=" "!($L(SIG9(FFFF))=ZZZZ) S SGCT=SGCT+1 D I $L(LVAR)>PSLONG S SGY(LLLL)=LLIM_" ",LLLL=LLLL+1,LVAR=LVAR1
.S LVAR1=$P(SIG9(FFFF)," ",(SGCT))
.S LLIM=LVAR
.S LVAR=$S(LVAR="":LVAR1,1:LVAR_" "_LVAR1)
I $G(LVAR)'="" S SGY(LLLL)=LVAR
I '$P(PSOPAR,"^",28) S SGC=0 F CTCT=0:0 S CTCT=$O(SGY(CTCT)) Q:'CTCT S SGC=SGC+1
I $O(OSGY(0)) D
.F I=0:0 S I=$O(SGY(I)) Q:'I I $G(OSGY(I))']"" S OSGY(I)=" "
.F I=0:0 S I=$O(OSGY(I)) Q:'I I $G(SGY(I))']"" S SGY(I)=" "
Q
;
OPAI ; OPAI interface for One-Va prescriptions
N PSOOLAN,PSOOTLAN,PSOND1,PSOND2,PSOND3,PSOXN2,DDNS,DPORT,OPADD,DFN,PSODFN,PSOLLNM,PAS,PAS3,PSI,HLECH,CS,RS,EC,SCS,DTME,PSODTM,PSOENH,PSOADD,PSONEADS,PSONECT,PSONECTC
S (DFN,PSODFN)=$G(PSOHLSV("PATIENT DFN")) Q:'PSODFN
S PSOLDRUG=$G(PSOHLSV("L_DRUGIEN")) I 'PSOLDRUG Q
S PSOLLNM=$P($G(^PSDRUG(PSOLDRUG,0)),"^")
S PSOND1=$P($G(^PSDRUG(PSOLDRUG,"ND")),"^"),PSOND2=$P($G(^("ND")),"^",2),PSOND3=$P($G(^("ND")),"^",3)
I PSOND1,PSOND3 S PSOXN2=$$PROD2^PSNAPIS(PSOND1,PSOND3)
S PSOOLAN=$P($G(^PS(55,DFN,"LAN")),"^",2),PSOOTLAN="N" I PSOOLAN=2 S PSOOTLAN="Y"
K PAS,PAS3
S PSOHLINX=$$GETAPP^HLCS2("PSO VISTA") Q:$P($G(PSOHLINX),"^",2)="i"
K ^TMP("PSO",$J)
S PIEN=$O(^ORD(101,"B","PSO EXT SERVER",0)) Q:'PIEN
S PSI=1,HLPDT=DT D INIT^HLFNC2(PIEN,.HL1) I $G(HL1) Q
S FS=HL1("FS"),HL1("ECH")="~^\&",HLECH=HL1("ECH"),CS=$E(HL1("ECH")),RS=$E(HL1("ECH"),2),EC=$E(HL1("ECH"),3),SCS=$E(HL1("ECH"),4)
D NOW^%DTC S (DTME,PSODTM)=%
S DDNS=$$GET1^DIQ(59,PSOSITE_",",2006)
;NO NEED FOR TMP(PSOMID) ONLY STORING IN 52.51
S PSONECT=1,PSONECTC=0
S PSOENH=0,^UTILITY($J,"PSOPAI")=IOS D GETDEV^PSOHLDS,ALLADD^PSOHLDS ;sets up OPADD array
K ^UTILITY($J,"PSOPAI") S PSOADD=""
I PSOENH S PSONEADS=1 D CHKCAT^PSOHLDS K PSONEADS I PSOADD="" Q
I PSOADD="" S PSOADD=DDNS
S PSI=$P(OPADD(PSOADD),"^",2) I PSI="" S PSI=1 K PAS,PAS3
D PID^PSOHLDS5(.PSI),PV1^PSOHLDS5(.PSI),PV2^PSOHLDS5(.PSI),IAM^PSOHLDS4(.PSI),ORC^PSOHLDS5(.PSI),NTE1^PSOHLDS5(.PSI),NTE2^PSOHLDS5(.PSI),NTE3^PSOHLDS5(.PSI)
D NTE4^PSOHLDS5(.PSI),RXE^PSOHLDS5(.PSI),RXD^PSOHLDS5(.PSI)
D NTEPMI^PSOHLDS5(.PSI)
D NTE9^PSOHLDS2(.PSI)
D RXR^PSOHLDS5(.PSI)
D ZZZ^PSOHLDS5(.PSI)
M ^TMP("PSOADD",$J,PSOADD)=^TMP("PSO",$J) S $P(OPADD(PSOADD),"^",2)=PSI
I $D(ADDCAT("S")) D STRAGE^PSOHLDS
K ^TMP("PSO",$J)
I $D(ADDCAT("S")) D MORSTG^PSOHLDS
S DDNS="" F S DDNS=$O(^TMP("PSOADD",$J,DDNS)) Q:DDNS="" D
.K ^TMP("HLS",$J)
.M ^TMP("HLS",$J)=^TMP("PSOADD",$J,DDNS)
.S DPORT=$P(OPADD(DDNS),"^")
.K HLP,HLMID,HLERR,HLRESLT
.S HLP("CONTPTR")="",HLP("SUBSCRIBER")="^^^^~"_DDNS_":"_DPORT_"~DNS"
.D GENERATE^HLMA(PIEN,"GM",1,.HLRESLT,"",.HLP)
.K HLL S HLMID=$P($G(HLRESLT),"^"),HLERR=$P($G(HLRESLT),"^",2)
.I '$G(HLMID)!($P($G(HLERR),"^")'="") D Q
..S XQAMSG="Error transmitting OneVa Rx "_$G(PSOHLSV("RX NUMBER"))_"to external interface"_$S(PSOENH:" TO "_DDNS,1:"") D ALERT^PSOHLDS Q
.I HLMID'="",$G(PSOHLSV("RX LOG IEN"))'="" D
..S $P(^PSRXR(52.09,PSOHLSV("RX LOG IEN"),4),"^")=HLMID
..S ^PSRXR(52.09,"F",HLMID,PSOHLSV("RX LOG IEN"))=""
..S $P(^PSRXR(52.09,PSOHLSV("RX LOG IEN"),4),"^",3)=$G(OPNAM(DDNS))
..S $P(^PSRXR(52.09,PSOHLSV("RX LOG IEN"),4),"^",4)=$G(DDNS)
..I PSONECTC>1 S $P(^PSRXR(52.09,PSOHLSV("RX LOG IEN"),4),"^",5)=1
;IS ACK+13^PSOHLDS CHECK STILL VALID
Q
;
ACK ;Process ack from OPAI dispense for a OneVa fill, called from PSOHLDS
N PSOPAID,PSOAI,PSOORC,PSORXD,PSOPID,PSOFILPR,PSOCHKPH,PSOHLOT,PSODEXP,PSOHMAN,PSOHNDC
S PSOPAID("IEN")=$O(^PSRXR(52.09,"F",SMID,0)) Q:'$G(PSOPAID("IEN"))
F PSOAI=0:0 S PSOAI=$O(PSOMSG(PSOAI)) Q:'PSOAI D
.I $P(PSOMSG(PSOAI),"|")="PID" S PSOPID=PSOMSG(PSOAI) Q
.I $P(PSOMSG(PSOAI),"|")="ORC" S PSOORC=PSOMSG(PSOAI) Q
.I $P(PSOMSG(PSOAI),"|")="RXD" S PSORXD=PSOMSG(PSOAI) Q
;
;Set data in PSOPAID array
S PSOPAID("RX")=$P($P($G(PSOORC),"|",3),"^")
S PSOFILPR=$P($P($G(PSOORC),"|",11),"~"),PSOPAID("PSOFILPR")=$$GET1^DIQ(200,PSOFILPR,.01,"E")
S PSOPAID("PSOFILPR")=$E(PSOPAID("PSOFILPR"),1,45)
S PSOCHKPH=$P($P($G(PSOORC),"|",12),"~"),PSOPAID("PSOCHKPH")=$$GET1^DIQ(200,PSOCHKPH,.01,"E")
S PSOPAID("PSOCHKPH")=$E(PSOPAID("PSOCHKPH"),1,45)
S PSOHLOT=$P($P($G(PSORXD),"|",19),"^")
S PSODEXP=$P($P($G(PSORXD),"|",20),"^")
S PSOHMAN=$P($P($G(PSORXD),"|",21),"^")
S PSOHMAN=$E(PSOHMAN,1,50)
S PSOHNDC=$P($P($G(PSORXD),"|",10),"^")
;set fields from rxd, and get 52.09 ien, refill or partial, and associated sub-ien, and DOMOVR send back message and process
D UPD
D SEND^PSOHLDS5
D ACKK
Q
;
ACKK ;
K HL,AACK,DTM,ETN,CMID,MTN,RAN,SAN,VER,EID,EIDS,FS,ORC,PSOMSG,HLQUIT,HLNODR,MSACDE,SMID,ERRMSG,PSOFNHL7
Q
;
UPD ;Update File 52.09 at dispensing site
S $P(^PSRXR(52.09,PSOPAID("IEN"),0),"^",11)=$G(PSOPAID("PSOFILPR"))
S $P(^PSRXR(52.09,PSOPAID("IEN"),0),"^",12)=$G(PSOPAID("PSOCHKPH"))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORLLLI 15100 printed Apr 09, 2024@21:35:43 Page 2
PSORLLLI ;AITC/BWF - ONEVA LASER LABELS INITIALIZATION ;10/06/16 9:28am
+1 ;;7.0;OUTPATIENT PHARMACY;**454,643,728**;DEC 1997;Build 5
+2 ;
+3 ;DBIAs PSDRUG-221, PS(55-2228, SC-10040, IBARX-125, PSXSRP-2201, %ZIS-3435, DPT-3097, ^TMP($J,"PSNPPIO"-3794
+4 ;External reference to DRUG^PSSWRNA supported by DBIA 4449
+5 ;External reference to $$DS^PSSDSAPI supported by DBIA 5425
+6 ;External reference to ^DIC(5 supported by DBIA 4293
+7 ;External reference to ^SC( supported by DBIA 2675
+8 ;External reference to $$DS^PSSDSAPI supported by DBIA 5425
+9 ;External reference to ^ORD(101 supported by DBIA 872
+10 ;External reference to ^PS(51 supported by DBIA 2224
+11 ;External reference to ^PSNDF supported by DBIA 2195
+12 ;External reference to ^%ZIS(2 supported by DBIA 3435
+13 ;
+14 ;*244 remove test for partial fill when testing status > 11
+15 ;
DQ NEW PSOBIO,PSOXINT,PSOXMARK
SET (I,PSOIO)=0
FOR
SET I=$ORDER(^%ZIS(2,IOST(0),55,I))
if 'I
QUIT
SET X0=$GET(^(I,0))
IF X0]""
SET PSOIO($PIECE(X0,"^"))=^(1)
SET PSOIO=1
+1 IF '$GET(PSOHLSV("PATCH INSTALLED FLAG"))!($GET(PSOLONLY))
GOTO DQS
+2 SET PSOXINT=$PIECE($GET(^PS(59,PSOSITE,1)),"^",30)
+3 SET PSOXMARK=0
+4 if +$GET(PSOHLSV("L_DRUGIEN"))
SET PSOXMARK=+$GET(^PSDRUG(+PSOHLSV("L_DRUGIEN"),6))
+5 IF $SELECT(PSOXINT=1:1,PSOXINT=2:1,PSOXINT=3:PSOXMARK,PSOXINT=4:PSOXMARK,1:0)
DO OPAI
+6 IF $SELECT(PSOXINT=2:1,PSOXINT=3:PSOXMARK,1:0)
GOTO HLEX
DQS IF '$DATA(^%ZIS(2,IOST(0),55,"B","LL"))
GOTO HLEX
DQ1 IF '$DATA(RPPL)
GOTO HLEX
+1 IF $DATA(PSOIOS)
IF PSOIOS]""
DO DEVBAR^PSOBMST
+2 KILL RRXFLX,RXFDAMG
SET PSOCKHN=","_$GET(RPPL)
SET PSRESOLV=+RPPL
DO CHECK
+3 SET PSOINT=1
FOR PI=1:1
SET RX=$PIECE(RPPL,",",PI)
if RX=""
QUIT
Begin DoDot:1
+4 SET PSOPDFN=$GET(PSODFN)
SET RXY=$GET(RX0)
+5 KILL RXP,REPRINT
DO C
End DoDot:1
+6 IF 'PSOINT
DO TRAIL^PSORLLL1
+7 ;
HLEX KILL RXPI,PSORX,RXP,PSOIOS,PSOLAPPL,XXX,COPAYVAR,TECH,PHYS,MFG,NURSE,STATE,SIDE,COPIES,EXDT,ISD,PSOINST,RXN,RXY,VADT,DEA,WARN,FDT,QTY,PATST,PDA,PS,PS1,RXP,REPRINT
+1 KILL SGY,OSGY,PS2,PSL,PSNP,INRX,RR,XTYPE,SSNP,SSNPN,PNM,ADDR,PSODBQ,PSOLASTF,PSRESOLV,PSOEXREP,PSOSXQ
+2 KILL DATE,DR,DRUG,LINE,MW,PRTFL,VRPH,EXPDT,X2,DIFF,DAYS,PSZIP,PSOHZIP,PS55,PS55X,REF
+3 KILL ^TMP($JOB,"PSNPMI"),^TMP($JOB,"PSOCP",+$GET(PSOCPN)),PSOCPN,PSOLBLDR,PSOLBLPS,PSOLBLCP,RRXPR,RXRP,RXRS,PSOCKHN,RXFLX,PSOLAPPL,PSOPDFN,PSDFNFLG,PSOZERO,NEXTRX,PSOBLALL,STA
+4 ; NEW kill lines for cleanup - OneVA Pharmacy
+5 KILL RX0,RX2,RX3,RXSTA,HINFO,RSIG,PSODFN,LOCDRUG,ROR1,RPAR0,RREF0,RFIEN,PARIEN,RIEN,PATST,RRFTYP,RRXFL,RRXPR,RSIG1,RPPL,HINFOST
+6 KILL BOTTLBL,CONT,DOB,F8,FILLCONT,FLAG,JJ,L2,L3,L4,L5,LENGTH,MAILCOM,NOBARC,NOR,OFONT,OPSOX,OPSOY,ORS,OUT,PATSTIEN
+7 KILL PFM,PI,PIMI,PLANNM,PMIM,PPHYS,PRCOPAY,PSCAP,PSCLN,PSDU,PSMP,PSOBY,PSOBYI,PSOCX,PSODFONT,PSODY,PSOFLAST,PSOFNOW
+8 KILL PSOFONT,PSOFY,PSOHFONT,PSOINT,PSOLAN,PSONOW,PSONOWT,PSOQFONT,PSOQY,PSORYI,PSOSITE7,PSOSUREP,PSOSUSPR,PSOTFONT,X0,ZDRUG
+9 KILL PSOTRAIL,PSOTY,PSOTYI,PSOYI,PSOYM,PTEXT,Q,EXP,PSLION,PSOBLRX,PSOHYI,PSOIO,SGC,SIG1,SIGDONE,SIGM,SS,ULN,VAADDR1,WARN5,ZY
+10 IF '$GET(PSOSUREP)
IF '$GET(PSOSUSPR)
DO ^%ZISC
SET ZTREQ="@"
+11 QUIT
+12 ;
C NEW PSOBIO
SET (I,PSOIO)=0
FOR
SET I=$ORDER(^%ZIS(2,IOST(0),55,I))
if 'I
QUIT
SET X0=$GET(^(I,0))
IF X0]""
SET PSOIO($PIECE(X0,"^"))=^(1)
SET PSOIO=1
+1 USE IO
if '$DATA(RX0)
QUIT
SET RXY=$GET(RX0)
SET RX2=$GET(RX2)
SET RXSTA=$GET(RXSTA)
SET RREF0=$GET(RREF0)
SET RPAR0=$GET(RPAR0)
KILL SGY,OSGY
+2 SET (SIGM,PFM,PMIM,L2,L3,L4,L5,FILLCONT,BOTTLBL)=0
+3 KILL SIGF,PFF,PMIF
SET (SIGF,PFF,PMIF)=0
FOR I="DR","T"
SET (SIGF(I),PFF(I))=1
+4 FOR I="A","B","I"
SET PMIF(I)=1
+5 DO NOW^%DTC
SET Y=$PIECE(%,".")
SET PSOFNOW=%
XECUTE ^DD("DD")
SET PSONOW=Y
SET Y=PSOFNOW
XECUTE ^DD("DD")
SET PSONOWT=Y
+6 if $GET(PSOBLALL)
SET PSOBLRX=RX
if $DATA(RRXPR(RX))
SET RXP=RRXPR(RX)
+7 SET RXY=$GET(RX0)
SET RX2=$GET(RX2)
SET RXSTA=$GET(RXSTA)
SET RREF0=$GET(RREF0)
SET RPAR0=$GET(RPAR0)
SET ROR1=$GET(ROR1)
SET RSIG=$GET(RSIG)
SET RSIG1=$GET(RSIG1)
+8 KILL ^UTILITY("DIQ1",$JOB)
SET DA=$PIECE($$SITE^VASITE(),"^")
+9 IF $GET(DA)
SET DIC=4
SET DIQ(0)="I"
SET DR="99"
DO EN^DIQ1
SET PSOINST=$GET(^UTILITY("DIQ1",$JOB,4,DA,99,"I"))
KILL ^UTILITY("DIQ1",$JOB),DA,DR,DIC
+10 SET RXN=$PIECE(RXY,"^")
SET DFN=$GET(PSODFN)
SET PSOLBLPS=+$PIECE(RXY,"^",3)
SET PSOLBLDR=+$GET(LOCDRUG)
+11 SET ISD=$PIECE(RXY,"^",13)
SET RXF=0
SET SIG=$PIECE($GET(RSIG),"^")
SET ISD=$EXTRACT(ISD,4,5)_"/"_$EXTRACT(ISD,6,7)_"/"_($EXTRACT(ISD,1,3)+1700)
SET ZY=0
SET $PIECE(LINE,"_",28)="_"
+12 SET NURSE=$SELECT($PIECE($GET(^DPT(DFN,"NHC")),"^")="Y":1,$PIECE($GET(^PS(55,DFN,40)),"^"):1,1:0)
+13 SET FDT=$PIECE(RX2,"^",2)
SET PS=$SELECT($DATA(^PS(59,PSOSITE,0)):^(0),1:"")
SET PS1=$SELECT($DATA(^(1)):^(1),1:"")
SET PSOSITE7=$PIECE(^("IB"),"^")
+14 SET PS2=$PIECE($GET(HINFO),"^")_"^"_$PIECE($GET(HINFO),"^",4)
+15 SET EXPDT=$PIECE(RX2,"^",6)
SET EXDT=$SELECT('EXPDT:"",1:$EXTRACT(EXPDT,4,5)_"/"_$EXTRACT(EXPDT,6,7)_"/"_($EXTRACT(EXPDT,1,3)+1700))
+16 SET COPIES=$SELECT($PIECE(RXY,"^",18)]"":$PIECE(RXY,"^",18),1:1)
+17 KILL PSOCKHNX
SET PSOCKHL=$LENGTH(RX)
SET PSOCKHN=$EXTRACT($GET(PSOCKHN),(PSOCKHL+2),999)
Begin DoDot:1
+18 SET PSOCKHA=","_RX_","
+19 IF PSOCKHN'[PSOCKHA
QUIT
+20 SET PSOCKHA=$EXTRACT(PSOCKHA,1,($LENGTH(PSOCKHA)-1))
+21 SET PSOCKHNX=$LENGTH(PSOCKHN,PSOCKHA)-1
+22 IF +$GET(PSOCKHNX)>0
DO DOUB
End DoDot:1
KILL PSOCKHNX,PSOCKHL,PSOCKHA
+23 IF '$GET(RXP)
DO OSET
+24 IF '$GET(RXP)
Begin DoDot:1
+25 IF '$GET(RRXFL(RX))
SET XTYPE=1
DO REF
End DoDot:1
GOTO STA
+26 IF $GET(RXP)
SET XTYPE="P"
DO REF
GOTO STA
ORIG SET TECH=$PIECE(RXY,"^",16)
SET PHYS=$SELECT($PIECE(RXY,"^",4)'="":$PIECE(RXY,"^",4),1:"UKN")
+1 SET DAYS=$PIECE(RXY,"^",8)
SET QTY=$PIECE(RXY,"^",7)
+2 DO 6^VADPT
DO PID^VADPT6
SET SSNPN=""
STA ;
+1 SET HINFOST=$PIECE($PIECE(HINFO,U,2),"~",4)
+2 SET STATE=$SELECT($GET(HINFOST)'="":HINFOST,1:"UKN")
+3 SET DRUG=$$ZZ($GET(LOCDRUG))
SET DEA=$PIECE($GET(^PSDRUG(+$GET(LOCDRUG),0)),"^",3)
SET WARN=$PIECE($GET(^(0)),"^",8)
+4 SET WARN=$$DRUG^PSSWRNA(+$GET(LOCDRUG),+$GET(DFN))
+5 IF $GET(PARIEN)
SET RXPI=$GET(PARIEN)
Begin DoDot:1
+6 SET RXP=$GET(RPAR0)
+7 SET RXY=$PIECE(RXP,"^")_"^"_$PIECE(RXY,"^",2,6)_"^"_$PIECE(RXP,"^",4)_"^"_$PIECE(RXP,"^",10)_"^"_$PIECE(RXY,"^",9)_"^"_$PIECE($GET(RSIG),"^",2)_"^"_$PIECE(RXP,"^",2)_"^"_$PIECE(RXY,"^",12,14)_"^"_$PIECE(RXSTA,"^")_"^"_...
... $PIECE(RXP,"^",7)_"^"_$PIECE(RXY,"^",17,99)
+8 SET FDT=$PIECE(RXP,"^")
End DoDot:1
+9 SET MW=$PIECE(RXY,"^",11)
IF $GET(RRXFL(RX))'=0
if $GET(RRXFL(RX))
Begin DoDot:1
+10 IF $GET(RRXFL(RX))
IF '$LENGTH(RREF0)
KILL RRXFL(RX)
QUIT
+11 ;PSO*7*266
+12 SET RXF=RRXFL(RX)
if '$GET(RXP)
SET MW=$PIECE($GET(RREF0),"^",2)
SET FDT=+$GET(RREF0)
End DoDot:1
IF '$GET(RRXFL(RX))
SET RXF=$PIECE(RX0,"^",9)
if '$GET(RXP)
SET MW=$PIECE(RREF0,"^",2)
SET FDT=+$GET(RREF0)
+13 ; always 'W' for oneva pharmacy
+14 SET MW="W"
+15 ;New mail codes for CMOP
+16 SET MAILCOM=""
+17 SET X=$GET(^PS(55,DFN,0))
SET PSCAP=$PIECE(X,"^",2)
SET PS55=$PIECE(X,"^",3)
SET PS55X=$PIECE(X,"^",5)
+18 IF PS55X]""
IF PS55>1
IF PS55X<DT
SET PS55=0
+19 SET MW=$SELECT(MW="M":"REGULAR",MW="R":"CERTIFIED",1:"WINDOW")
+20 IF $GET(PSMP(1))=""
IF $GET(PS55)=2
SET PSMP(1)=$GET(SSNPN)
+21 SET DATE=$EXTRACT(FDT,1,7)
SET REF=$PIECE(RXY,"^",9)
if REF<1
SET REF=0
DO PSOLBL2
+22 SET PSOLASTF=$PIECE(RX3,"^")
+23 if $LENGTH(PSOLASTF)
SET PSOLASTF=$EXTRACT(PSOLASTF,4,5)_"/"_$EXTRACT(PSOLASTF,6,7)_"/"_$EXTRACT(PSOLASTF,2,3)
+24 IF '$LENGTH(PSOLASTF)
SET PSOLASTF="N/A"
+25 SET (X,PSOFLAST)=$GET(PSOLASTF)
IF X?1N.E
DO ^%DT
XECUTE ^DD("DD")
SET PSOFLAST=Y
+26 SET PATST=$GET(PATST)
+27 IF PATST]""
IF $DATA(^PS(53,"C",PATST))
SET PATSTIEN=$ORDER(^PS(53,"C",PATST,0))
+28 IF $GET(PATSTIEN)
SET PATST=$GET(^PS(53,PATSTIEN,0))
+29 SET PRTFL=1
IF REF=0
if ('$PIECE(PATST,"^",5))!(DEA["W")!(DEA[1)!(DEA[2)
SET PRTFL=0
+30 SET VRPH=$PIECE(RX2,"^",10)
SET PSCLN=$SELECT($PIECE($GET(HINFO),U,5)]"":$PIECE(HINFO,U,5),1:"OneVA")
+31 SET PATST=$PIECE(PATST,"^",2)
SET X1=DT
SET X2=$PIECE(RXY,"^",8)-10
if REF
DO C^%DTC
IF $DATA(RX2)
IF $PIECE(RX2,"^",6)
IF REF
IF X'<$PIECE(RX2,"^",6)
SET REF=0
SET VRPH=$PIECE(RX2,"^",10)
+32 IF $GET(RXP)
SET COPAYVAR=""
GOTO LBL
+33 IF $PIECE(RXSTA,"^")>0
IF $PIECE(RXSTA,"^")'=2
IF '$GET(PSODBQ)
DO SNO
GOTO LBL
LBL IF $GET(PSOIO("LLI"))]""
XECUTE PSOIO("LLI")
LBL2 SET PSOINT=0
GOTO ^PSORLLL1
REF SET TECH=$SELECT(XTYPE=1:$PIECE($GET(RREF0),"^",7),XTYPE="P":$PIECE($GET(RPAR0),"^",7),1:"UNKNOWN")
+1 SET QTY=$SELECT(XTYPE=1:$PIECE(RREF0,U,4),XTYPE="P":$PIECE(RPAR0,U,4),1:"")
+2 IF XTYPE=1
SET PHYS=$SELECT($PIECE($GET(RREF0),"^",17)]"":$PIECE($GET(RREF0),"^",17),1:"UNKNOWN")
+3 IF XTYPE="P"
SET PHYS=$SELECT($PIECE($GET(RPAR0),"^",17)]"":$PIECE($GET(RPAR0),"^",17),1:"UNKNOWN")
+4 SET DAYS=$SELECT(XTYPE=1:$PIECE(RREF0,U,10),XTYPE="P":$PIECE(RPAR0,U,10),1:"")
+5 QUIT
CHECK ; use DFN from ZTSAVE instead of from RX
+1 SET PSDFNFLG=0
SET PSOZERO=$PIECE(RPPL,",")
SET PSOPDFN=$GET(DFN)
+2 QUIT
OSET ;
+1 NEW A
+2 IF $GET(RRXFL(RX))']""!($GET(RRXFL(RX))=0)
Begin DoDot:1
+3 SET A=$GET(RX0)
+4 SET TECH=$PIECE(A,"^",16)
SET QTY=$PIECE(A,"^",7)
SET PHYS=$SELECT($PIECE(A,"^",4)]"":$PIECE(A,"^",4),1:"UKN")
DO 6^VADPT
DO PID^VADPT6
SET SSNPN=""
+5 SET DAYS=$PIECE(A,"^",8)
End DoDot:1
QUIT
+6 IF $GET(RREF0)']""
KILL RRXFL(RX)
QUIT
+7 SET A=$GET(RREF0)
+8 SET TECH=$SELECT($PIECE(A,"^",7)]"":$PIECE(A,"^",7),1:"UNKNOWN")
+9 SET QTY=$PIECE(A,"^",4)
SET PHYS=$SELECT($PIECE(A,"^",17)]"":$PIECE(A,"^",17),1:"UNKNOWN")
DO 6^VADPT
DO PID^VADPT6
SET SSNPN=""
+10 SET DAYS=$PIECE(A,"^",10)
+11 QUIT
DOUB ;
+1 if '$DATA(RRXFL(RX))
QUIT
+2 IF +$GET(RRXFL(RX))-PSOCKHNX<0
QUIT
+3 SET RRXFLX(RX)=$GET(RRXFL(RX))
+4 SET RRXFL(RX)=$GET(RRXFL(RX))-PSOCKHNX
+5 QUIT
SNO ;
+1 SET COPAYVAR="NO COPAY"
+2 QUIT
ZZ(LDIEN) ; Returns VA print name, Trade Name, Generic Name
+1 SET I50=LDIEN
SET ZDRUG=$PIECE(^PSDRUG(I50,0),U)
+2 IF $GET(ZDRUG)']""
SET ZDRUG="DRUG NOT ON FILE ("_I50_")"
GOTO END
+3 IF $DATA(^PSDRUG("AQ",I50))
IF ($DATA(^PSDRUG(I50,"ND")))
Begin DoDot:1
+4 SET Z1=$PIECE($GET(^PSDRUG(I50,"ND")),U)
SET Z2=$PIECE($GET(^("ND")),U,3)
+5 IF $GET(Z1)
IF ($GET(Z2))
Begin DoDot:2
+6 IF $TEXT(^PSNAPIS)]""
SET PSOXN=$$PROD2^PSNAPIS(Z1,Z2)
SET ZDRUG=$PIECE($GET(PSOXN),"^")
KILL PSOXN
QUIT
+7 SET ZDRUG=$PIECE($GET(^PSNDF(Z1,5,Z2,2)),"^")
End DoDot:2
+8 KILL Z1,Z2,I50
End DoDot:1
END KILL I50
+1 QUIT ZDRUG
+2 ; copy of PSOLBL2 logic
PSOLBL2 ;
+1 ;I $P($G(SIG),"^",2) K SGY D PSOLBL3 G SIGOLD
+2 IF $PIECE($GET(RSIG),"^")]""
SET SIG=$PIECE($GET(RSIG),"^")
DO SIG
QUIT
+3 SET SIGDONE=0
+4 FOR I=1:1
Begin DoDot:1
+5 IF '$DATA(RSIG1(I))
SET SIGDONE=1
QUIT
+6 IF '$LENGTH(SIG)
SET SIG=$GET(RSIG1(I))
QUIT
+7 SET SIG=$GET(SIG)_" "_$GET(RSIG1(I))
End DoDot:1
if SIGDONE
QUIT
+8 DO SIG
QUIT KILL SIG,E,F,S
QUIT
SIG KILL OT
SET SGY=""
FOR P=1:1:$LENGTH(SIG," ")
SET X=$PIECE(SIG," ",P)
if X]""
Begin DoDot:1
+1 IF $DATA(^PS(51,"A",X))
Begin DoDot:2
+2 ;PSO*7*282 Intended use
+3 IF $PIECE($GET(^PS(55,DFN,"LAN")),"^")
SET OT=$ORDER(^PS(51,"B",X,0))
IF OT
IF $PIECE($GET(^PS(51,OT,0)),"^",4)<2
IF $PIECE($GET(^PS(51,OT,4)),"^")]""
SET X=$PIECE(^PS(51,OT,4),"^")
KILL OT
QUIT
+4 SET %=^PS(51,"A",X)
SET X=$PIECE(%,"^")
IF $PIECE(%,"^",2)]""
SET Y=$PIECE(SIG," ",P-1)
SET Y=$EXTRACT(Y,$LENGTH(Y))
if Y>1
SET X=$PIECE(%,"^",2)
End DoDot:2
+5 SET SGY=SGY_X_" "
End DoDot:1
+6 SET X=""
SET SGC=1
FOR J=1:1
SET Z=$PIECE(SGY," ",J)
if Z=""
SET SGY(SGC)=X
if Z=""
QUIT
if $LENGTH(X)+$LENGTH(Z)'<$SELECT($PIECE(PSOPAR,"^",28)
SET SGY(SGC)=X
SET SGC=SGC+1
SET X=""
SET X=X_Z_" "
SIGOLD IF '$PIECE(PSOPAR,"^",28)
Begin DoDot:1
+1 KILL DIC,DR,DIQ,NHC
SET DIC=2
SET DA=DFN
SET DR=148
SET DIQ="NHC"
SET DIQ(0)="I"
+2 DO EN^DIQ1
KILL DIC,DR,DIQ
+3 IF NHC(2,DFN,148,"I")="Y"!($PIECE($GET(^PS(55,DFN,40)),"^"))
SET SGC=SGC+1
SET SGY(SGC)="Expiration:________ Mfg:_________"
End DoDot:1
KILL NHC
+4 ;
DPT SET X=$SELECT($DATA(^DPT(DFN,0))#2:^(0),1:"")
SET DOB=$PIECE(X,"^",3)
SET L=$EXTRACT(X,1)
+1 SET Y=$PIECE(X,"^",9)
SET PNM=$PIECE(X,"^")
DO PID^VADPT
SET SS=""
SET SSNP=""
+2 IF $PIECE(PSOPAR,"^",28)
KILL SIG,E,F,S
QUIT
+3 QUIT
+4 ;--- end PSOLBL2 LOGIC
PSOLBL3 ;
+1 NEW CTCT,FFFF,LLIM,LLLL,LVAR,LVAR1,PPP,PPPP,SGCT,SIG9,OSIG,ZZZZ,PSLONG,PPPP
+2 SET PSLONG=$SELECT($PIECE(PSOPAR,"^",28):46,1:34)
+3 ; NEXT LINE IF SIG IS MOVED BACK TO MULTIPLE
+4 SET PPPP=1
FOR PPP=0:0
SET PPP=$ORDER(RSIG1(PPP))
if 'PPP
QUIT
IF $GET(RSIG1(PPP))'=""
SET SIG9(PPPP)=$GET(SIG1("SIG1",PPP))
SET PPPP=PPPP+1
+5 ;NEXT LINE IF 1ST FRONT DOOR SIG LINE LIVES IN BACK DOOR SPOT
+6 ;S SIG9(1)=$P($G(^PSRX(RX,"SIG")),"^") S PPP=2 F PPPP=0:0 S PPPP=$O(^PSRX(RX,"SIG1",PPPP)) Q:'PPPP I $G(^(PPPP,0))'="" S SIG9(PPP)=$G(^(0)),PPP=PPP+1
FMSIG SET (LVAR,LVAR1)=""
SET LLLL=1
+1 FOR FFFF=0:0
SET FFFF=$ORDER(SIG9(FFFF))
if 'FFFF
QUIT
SET SGCT=0
FOR ZZZZ=1:1:$LENGTH(SIG9(FFFF))
IF $EXTRACT(SIG9(FFFF),ZZZZ)=" "!($LENGTH(SIG9(FFFF))=ZZZZ)
SET SGCT=SGCT+1
Begin DoDot:1
+2 SET LVAR1=$PIECE(SIG9(FFFF)," ",(SGCT))
+3 SET LLIM=LVAR
+4 SET LVAR=$SELECT(LVAR="":LVAR1,1:LVAR_" "_LVAR1)
End DoDot:1
IF $LENGTH(LVAR)>PSLONG
SET SGY(LLLL)=LLIM_" "
SET LLLL=LLLL+1
SET LVAR=LVAR1
+5 IF $GET(LVAR)'=""
SET SGY(LLLL)=LVAR
+6 IF '$PIECE(PSOPAR,"^",28)
SET SGC=0
FOR CTCT=0:0
SET CTCT=$ORDER(SGY(CTCT))
if 'CTCT
QUIT
SET SGC=SGC+1
+7 IF $ORDER(OSGY(0))
Begin DoDot:1
+8 FOR I=0:0
SET I=$ORDER(SGY(I))
if 'I
QUIT
IF $GET(OSGY(I))']""
SET OSGY(I)=" "
+9 FOR I=0:0
SET I=$ORDER(OSGY(I))
if 'I
QUIT
IF $GET(SGY(I))']""
SET SGY(I)=" "
End DoDot:1
+10 QUIT
+11 ;
OPAI ; OPAI interface for One-Va prescriptions
+1 NEW PSOOLAN,PSOOTLAN,PSOND1,PSOND2,PSOND3,PSOXN2,DDNS,DPORT,OPADD,DFN,PSODFN,PSOLLNM,PAS,PAS3,PSI,HLECH,CS,RS,EC,SCS,DTME,PSODTM,PSOENH,PSOADD,PSONEADS,PSONECT,PSONECTC
+2 SET (DFN,PSODFN)=$GET(PSOHLSV("PATIENT DFN"))
if 'PSODFN
QUIT
+3 SET PSOLDRUG=$GET(PSOHLSV("L_DRUGIEN"))
IF 'PSOLDRUG
QUIT
+4 SET PSOLLNM=$PIECE($GET(^PSDRUG(PSOLDRUG,0)),"^")
+5 SET PSOND1=$PIECE($GET(^PSDRUG(PSOLDRUG,"ND")),"^")
SET PSOND2=$PIECE($GET(^("ND")),"^",2)
SET PSOND3=$PIECE($GET(^("ND")),"^",3)
+6 IF PSOND1
IF PSOND3
SET PSOXN2=$$PROD2^PSNAPIS(PSOND1,PSOND3)
+7 SET PSOOLAN=$PIECE($GET(^PS(55,DFN,"LAN")),"^",2)
SET PSOOTLAN="N"
IF PSOOLAN=2
SET PSOOTLAN="Y"
+8 KILL PAS,PAS3
+9 SET PSOHLINX=$$GETAPP^HLCS2("PSO VISTA")
if $PIECE($GET(PSOHLINX),"^",2)="i"
QUIT
+10 KILL ^TMP("PSO",$JOB)
+11 SET PIEN=$ORDER(^ORD(101,"B","PSO EXT SERVER",0))
if 'PIEN
QUIT
+12 SET PSI=1
SET HLPDT=DT
DO INIT^HLFNC2(PIEN,.HL1)
IF $GET(HL1)
QUIT
+13 SET FS=HL1("FS")
SET HL1("ECH")="~^\&"
SET HLECH=HL1("ECH")
SET CS=$EXTRACT(HL1("ECH"))
SET RS=$EXTRACT(HL1("ECH"),2)
SET EC=$EXTRACT(HL1("ECH"),3)
SET SCS=$EXTRACT(HL1("ECH"),4)
+14 DO NOW^%DTC
SET (DTME,PSODTM)=%
+15 SET DDNS=$$GET1^DIQ(59,PSOSITE_",",2006)
+16 ;NO NEED FOR TMP(PSOMID) ONLY STORING IN 52.51
+17 SET PSONECT=1
SET PSONECTC=0
+18 ;sets up OPADD array
SET PSOENH=0
SET ^UTILITY($JOB,"PSOPAI")=IOS
DO GETDEV^PSOHLDS
DO ALLADD^PSOHLDS
+19 KILL ^UTILITY($JOB,"PSOPAI")
SET PSOADD=""
+20 IF PSOENH
SET PSONEADS=1
DO CHKCAT^PSOHLDS
KILL PSONEADS
IF PSOADD=""
QUIT
+21 IF PSOADD=""
SET PSOADD=DDNS
+22 SET PSI=$PIECE(OPADD(PSOADD),"^",2)
IF PSI=""
SET PSI=1
KILL PAS,PAS3
+23 DO PID^PSOHLDS5(.PSI)
DO PV1^PSOHLDS5(.PSI)
DO PV2^PSOHLDS5(.PSI)
DO IAM^PSOHLDS4(.PSI)
DO ORC^PSOHLDS5(.PSI)
DO NTE1^PSOHLDS5(.PSI)
DO NTE2^PSOHLDS5(.PSI)
DO NTE3^PSOHLDS5(.PSI)
+24 DO NTE4^PSOHLDS5(.PSI)
DO RXE^PSOHLDS5(.PSI)
DO RXD^PSOHLDS5(.PSI)
+25 DO NTEPMI^PSOHLDS5(.PSI)
+26 DO NTE9^PSOHLDS2(.PSI)
+27 DO RXR^PSOHLDS5(.PSI)
+28 DO ZZZ^PSOHLDS5(.PSI)
+29 MERGE ^TMP("PSOADD",$JOB,PSOADD)=^TMP("PSO",$JOB)
SET $PIECE(OPADD(PSOADD),"^",2)=PSI
+30 IF $DATA(ADDCAT("S"))
DO STRAGE^PSOHLDS
+31 KILL ^TMP("PSO",$JOB)
+32 IF $DATA(ADDCAT("S"))
DO MORSTG^PSOHLDS
+33 SET DDNS=""
FOR
SET DDNS=$ORDER(^TMP("PSOADD",$JOB,DDNS))
if DDNS=""
QUIT
Begin DoDot:1
+34 KILL ^TMP("HLS",$JOB)
+35 MERGE ^TMP("HLS",$JOB)=^TMP("PSOADD",$JOB,DDNS)
+36 SET DPORT=$PIECE(OPADD(DDNS),"^")
+37 KILL HLP,HLMID,HLERR,HLRESLT
+38 SET HLP("CONTPTR")=""
SET HLP("SUBSCRIBER")="^^^^~"_DDNS_":"_DPORT_"~DNS"
+39 DO GENERATE^HLMA(PIEN,"GM",1,.HLRESLT,"",.HLP)
+40 KILL HLL
SET HLMID=$PIECE($GET(HLRESLT),"^")
SET HLERR=$PIECE($GET(HLRESLT),"^",2)
+41 IF '$GET(HLMID)!($PIECE($GET(HLERR),"^")'="")
Begin DoDot:2
+42 SET XQAMSG="Error transmitting OneVa Rx "_$GET(PSOHLSV("RX NUMBER"))_"to external interface"_$SELECT(PSOENH:" TO "_DDNS,1:"")
DO ALERT^PSOHLDS
QUIT
End DoDot:2
QUIT
+43 IF HLMID'=""
IF $GET(PSOHLSV("RX LOG IEN"))'=""
Begin DoDot:2
+44 SET $PIECE(^PSRXR(52.09,PSOHLSV("RX LOG IEN"),4),"^")=HLMID
+45 SET ^PSRXR(52.09,"F",HLMID,PSOHLSV("RX LOG IEN"))=""
+46 SET $PIECE(^PSRXR(52.09,PSOHLSV("RX LOG IEN"),4),"^",3)=$GET(OPNAM(DDNS))
+47 SET $PIECE(^PSRXR(52.09,PSOHLSV("RX LOG IEN"),4),"^",4)=$GET(DDNS)
+48 IF PSONECTC>1
SET $PIECE(^PSRXR(52.09,PSOHLSV("RX LOG IEN"),4),"^",5)=1
End DoDot:2
End DoDot:1
+49 ;IS ACK+13^PSOHLDS CHECK STILL VALID
+50 QUIT
+51 ;
ACK ;Process ack from OPAI dispense for a OneVa fill, called from PSOHLDS
+1 NEW PSOPAID,PSOAI,PSOORC,PSORXD,PSOPID,PSOFILPR,PSOCHKPH,PSOHLOT,PSODEXP,PSOHMAN,PSOHNDC
+2 SET PSOPAID("IEN")=$ORDER(^PSRXR(52.09,"F",SMID,0))
if '$GET(PSOPAID("IEN"))
QUIT
+3 FOR PSOAI=0:0
SET PSOAI=$ORDER(PSOMSG(PSOAI))
if 'PSOAI
QUIT
Begin DoDot:1
+4 IF $PIECE(PSOMSG(PSOAI),"|")="PID"
SET PSOPID=PSOMSG(PSOAI)
QUIT
+5 IF $PIECE(PSOMSG(PSOAI),"|")="ORC"
SET PSOORC=PSOMSG(PSOAI)
QUIT
+6 IF $PIECE(PSOMSG(PSOAI),"|")="RXD"
SET PSORXD=PSOMSG(PSOAI)
QUIT
End DoDot:1
+7 ;
+8 ;Set data in PSOPAID array
+9 SET PSOPAID("RX")=$PIECE($PIECE($GET(PSOORC),"|",3),"^")
+10 SET PSOFILPR=$PIECE($PIECE($GET(PSOORC),"|",11),"~")
SET PSOPAID("PSOFILPR")=$$GET1^DIQ(200,PSOFILPR,.01,"E")
+11 SET PSOPAID("PSOFILPR")=$EXTRACT(PSOPAID("PSOFILPR"),1,45)
+12 SET PSOCHKPH=$PIECE($PIECE($GET(PSOORC),"|",12),"~")
SET PSOPAID("PSOCHKPH")=$$GET1^DIQ(200,PSOCHKPH,.01,"E")
+13 SET PSOPAID("PSOCHKPH")=$EXTRACT(PSOPAID("PSOCHKPH"),1,45)
+14 SET PSOHLOT=$PIECE($PIECE($GET(PSORXD),"|",19),"^")
+15 SET PSODEXP=$PIECE($PIECE($GET(PSORXD),"|",20),"^")
+16 SET PSOHMAN=$PIECE($PIECE($GET(PSORXD),"|",21),"^")
+17 SET PSOHMAN=$EXTRACT(PSOHMAN,1,50)
+18 SET PSOHNDC=$PIECE($PIECE($GET(PSORXD),"|",10),"^")
+19 ;set fields from rxd, and get 52.09 ien, refill or partial, and associated sub-ien, and DOMOVR send back message and process
+20 DO UPD
+21 DO SEND^PSOHLDS5
+22 DO ACKK
+23 QUIT
+24 ;
ACKK ;
+1 KILL HL,AACK,DTM,ETN,CMID,MTN,RAN,SAN,VER,EID,EIDS,FS,ORC,PSOMSG,HLQUIT,HLNODR,MSACDE,SMID,ERRMSG,PSOFNHL7
+2 QUIT
+3 ;
UPD ;Update File 52.09 at dispensing site
+1 SET $PIECE(^PSRXR(52.09,PSOPAID("IEN"),0),"^",11)=$GET(PSOPAID("PSOFILPR"))
+2 SET $PIECE(^PSRXR(52.09,PSOPAID("IEN"),0),"^",12)=$GET(PSOPAID("PSOCHKPH"))
+3 QUIT
