PSORN52 ;BIR/DSD - files renewal entries in prescription file ;08-Apr-2014 13:51;DU
;;7.0;OUTPATIENT PHARMACY;**1,11,27,37,46,79,71,100,117,157,1005,143,219,148,239,201,225,303,1014,1017**;DEC 1997;Build 40
;Ext ref to ^PS(55 sup by DBIA 2228
;Ext ref to PSOUL^PSSLOCK sup by DBIA 2789
;Ext ref to ^VA(200 sup by DBIA 10060
;Ext ref to SWSTAT^IBBAPI sup by DBIA 4663
;
;Modified - IHS/CIA/PLS - 10/26/05 - New KILLOCM API
; IHS/MSC/PLS - 06/01/2010 - Line START+60
EN(PSOX) ;EP
START ;
D:$D(XRTL) T0^%ZOSV ; Start RT Mon
N PSOIBHLD,PSOSCOTH,PSOSCOTX S (PSOSCOTH,PSOSCOTX)=0 S PSOIBHLD="" I $G(PSOFDR),$G(ORD) D
.S PSOIBHLD=$S($P($G(^PS(52.41,ORD,0)),"^",16)="SC":1,$P($G(^(0)),"^",16)="NSC":0,1:"")
.I '$$DT^PSOMLLDT Q
.N PSOIBHLX S PSOIBHLX=$G(^PS(52.41,ORD,"IBQ"))
.S PSOIBHLD=PSOIBHLD_"^"_$S($P(PSOIBHLX,"^")=1:1,$P(PSOIBHLX,"^")=0:0,1:"")_"^"_$S($P(PSOIBHLX,"^",2)=1:1,$P(PSOIBHLX,"^",2)=0:0,1:"")_"^"_$S($P(PSOIBHLX,"^",3)=1:1,$P(PSOIBHLX,"^",3)=0:0,1:"")
.S PSOIBHLD=PSOIBHLD_"^"_$S($P(PSOIBHLX,"^",4)=1:1,$P(PSOIBHLX,"^",4)=0:0,1:"")_"^"_$S($P(PSOIBHLX,"^",5)=1:1,$P(PSOIBHLX,"^",5)=0:0,1:"")_"^"_$S($P(PSOIBHLX,"^",6)=1:1,$P(PSOIBHLX,"^",6)=0:0,1:"")
.S PSOIBHLD=PSOIBHLD_"^"_$S($P(PSOIBHLX,"^",7)=1:1,$P(PSOIBHLX,"^",7)=0:0,1:"")
.I $P(PSOIBHLX,"^")=1!($P(PSOIBHLX,"^",2)=1)!($P(PSOIBHLX,"^",3)=1)!($P(PSOIBHLX,"^",4)=1)!($P(PSOIBHLX,"^",5)=1)!($P(PSOIBHLX,"^",6)=1)!($P(PSOIBHLX,"^",7)=1) S PSOSCOTH=1
I $G(PSOSCOTH)!($G(PSORX("SC"))="SC")!($G(PSORX("SC"))="NSC") S PSOSCOTX=1
S PSOANSQ("SC>50")="" D SCP^PSORN52D
I $G(PSOFDR),$G(ORD) I $D(^PS(52.41,ORD,"ICD")) S FILE=52.41 D GET^PSORN52D
;Set ans to renew from Rx, only if no ans from Pend file
I $G(PSORENW("OIRXN")) D
.N PSOLDIBQ S PSOLDIBQ=$G(^PSRX(PSORENW("OIRXN"),"IBQ"))
.I $P(PSOIBHLD,"^")="" D
..I $P($G(^PSRX(PSORENW("OIRXN"),"IB")),"^")=2 S $P(PSOIBHLD,"^")=0
.I '$$DT^PSOMLLDT Q
.I PSOLDIBQ="" Q
.D IBHLD^PSORN52A
D INIT G:PSORN52("QFLG") END D FILE^PSORN52A
S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV ; Stop RT Mon
K PSOANSQ,PSOANSQD,PSONEWFF
I $G(PSOIBHLD)'="" D
.;Set answers based on Pend Renew, prior to Phar call
.Q:'$G(PSOX("IRXN"))
.I $P(PSOIBHLD,"^")=1!($P(PSOIBHLD,"^")=0) S PSOANSQ("SC")=$P(PSOIBHLD,"^")
.I '$$DT^PSOMLLDT Q
.I $P(PSOIBHLD,"^",2)=1!($P(PSOIBHLD,"^",2)=0) S PSOANSQ(PSOX("IRXN"),"MST")=$P(PSOIBHLD,"^",2)
.I $P(PSOIBHLD,"^",3)=1!($P(PSOIBHLD,"^",3)=0) S PSOANSQ(PSOX("IRXN"),"VEH")=$P(PSOIBHLD,"^",3)
.I $P(PSOIBHLD,"^",4)=1!($P(PSOIBHLD,"^",4)=0) S PSOANSQ(PSOX("IRXN"),"RAD")=$P(PSOIBHLD,"^",4)
.I $P(PSOIBHLD,"^",5)=1!($P(PSOIBHLD,"^",5)=0) S PSOANSQ(PSOX("IRXN"),"PGW")=$P(PSOIBHLD,"^",5)
.I $P(PSOIBHLD,"^",6)=1!($P(PSOIBHLD,"^",6)=0) S PSOANSQ(PSOX("IRXN"),"HNC")=$P(PSOIBHLD,"^",6)
.I $P(PSOIBHLD,"^",7)=1!($P(PSOIBHLD,"^",7)=0) S PSOANSQ(PSOX("IRXN"),"CV")=$P(PSOIBHLD,"^",7)
.I $P(PSOIBHLD,"^",8)=1!($P(PSOIBHLD,"^",8)=0) S PSOANSQ(PSOX("IRXN"),"SHAD")=$P(PSOIBHLD,"^",8)
K PSOIBHLD
I '$G(PSOFDR) I $G(PSORENW("OIRXN")) S FILE=52 D GET^PSORN52D
S PSONEW("NEWCOPAY")=""
I (PSOSCP<50&('$P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7))),$G(DUZ("AG"))="V" S PSOFLAG=0 D COPAY^PSOCPB
;I PSOSCP>49!($P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7)=1) S PSOFLAG=0 D SC^PSOMLLD2
I PSOSCA&(PSOSCP>49)!((PSOSCA!(PSOBILL=2))&($P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7)=1)) S PSOFLAG=0 D SC^PSOMLLD2
I $$DT^PSOMLLDT D
.I $D(PSOIBQS(PSODFN,"CV")) D MESS D CV^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"CV")) K PSONEW("NEWCOPAY")
.I $D(PSOIBQS(PSODFN,"VEH")) D MESS D VEH^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"VEH")) K PSONEW("NEWCOPAY")
.I $D(PSOIBQS(PSODFN,"RAD")) D MESS D RAD^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"RAD")) K PSONEW("NEWCOPAY")
.I $D(PSOIBQS(PSODFN,"PGW")) D MESS D PGW^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"PGW")) K PSONEW("NEWCOPAY")
.I $D(PSOIBQS(PSODFN,"SHAD")) D MESS D SHAD^PSOMLLD2 I $G(PSOANSQ(PSOX("IRXN"),"SHAD")) K PSONEW("NEWCOPAY")
.I $D(PSOIBQS(PSODFN,"MST")) D MESS D MST^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"MST")) K PSONEW("NEWCOPAY")
.I $D(PSOIBQS(PSODFN,"HNC")) D MESS D HNC^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"HNC")) K PSONEW("NEWCOPAY")
K PSOSCOTH,PSOSCOTX
I $G(PSONEW("NEWCOPAY")) S ^PSRX(PSOX("IRXN"),"IB")=PSONEW("NEWCOPAY")
;
D FINISH,ACP^PSOUTIL
;
N PSOSCFLD S PSOSCFLD=$S(PSOSCP'="":$G(PSOANSQ("SC")),1:"")_"^"_$G(PSOANSQ(PSOX("IRXN"),"MST"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"VEH"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"RAD"))
S PSOSCFLD=PSOSCFLD_"^"_$G(PSOANSQ(PSOX("IRXN"),"PGW"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"HNC"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"CV"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"SHAD"))
I PSOSCP<50&($TR(PSOSCFLD,"^")'="")&('$P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7)) S ^PSRX(PSOX("IRXN"),"IBQ")=PSOSCFLD K PSOSCFLD
;
D FILE2^PSORN52D
;IHS/MSC/PLS - 06/01/2010
;D:$$SWSTAT^IBBAPI() GACT^PSOPFSU0(PSOX("IRXN"),0)
K PSONEW("NEWCOPAY"),PSOANSQ
END D EOJ
Q
INIT S PSORN52("QFLG")=0 S:'$D(PSOX("DAYS SUPPLY")) PSOX("DAYS SUPPLY")=$P(PSOX("RX0"),"^",8)
S:'$D(PSOX("# OF REFILLS")) PSOX("# OF REFILLS")=$P(PSOX("RX0"),"^",9) S:'$D(PSOX("ISSUE DATE")) PSOX("ISSUE DATE")=DT
;IHS/MSC/MGH Set NDC code from drug file
S:'$D(PSOX("NDC")) PSOX("NDC")=$$NDCFMT^PSSNDCUT($$GET1^DIQ(50,+$G(PSOX("DRUG IEN")),31))
D INIT^PSON52 K PSON52
Q
;
FINISH ;
G:PSOX("STATUS")=4 FINISHP
I $D(PSORX("VERIFY")) D G FINISHX
.K DIC,DLAYGO,DINUM,DIADD,X,DD,DO S DIC="^PS(52.4,",DLAYGO=52.4,DINUM=PSOX("IRXN"),DIC(0)="ML"
.S X=PSOX("IRXN") D FILE^DICN K DD,DO,DIC,DLAYGO,DINUM,X
.S ^PS(52.4,PSOX("IRXN"),0)=PSOX("IRXN")_"^"_$P(PSOX("NRX0"),"^",2)_"^"_DUZ_"^"_$G(PSOX("OIRXN"))_"^"_$E(PSOX("LOGIN DATE"),1,7)_"^"_PSOX("IRXN")_"^"_PSOX("STOP DATE")
.K DIK,DA S DIK="^PS(52.4,",DA=PSOX("IRXN") D IX^DIK K DIK,DA
;
I $G(PSOX("QS"))="S",$G(PSOBARCD) S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=0 D SUS^PSORXL K DA G FINISHX
;
I PSOX("FILL DATE")>DT,$P(PSOPAR,"^",6) S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=0 D SUS^PSORXL K DA G FINISHX
;
; - Submitting Rx to ECME for 3rd Party Billing
N ACTION
I $$SUBMIT^PSOBPSUT(PSOX("IRXN"),0) D I ACTION="Q"!(ACTION="^") Q
. S ACTION="" D ECMESND^PSOBPSU1(PSOX("IRXN"),0,PSOX("FILL DATE"),"RN")
. I $$FIND^PSOREJUT(PSOX("IRXN"),0) D
. . S ACTION=$$HDLG^PSOREJU1(PSOX("IRXN"),0,"79,88","RN","IOQ","Q")
;
I $G(PSOX("QS"))="Q",$G(PSOBARCD) D G FINISHX
. N PSOFROM S PSOFROM="BATCH" I $G(PPL),$L(PPL_PSOX("IRXN")_",")>240 D TRI^PSOBBC D Q^PSORXL K PPL,RXFL
.S RXFL(PSOX("IRXN"))=0
. I $G(PPL) S PPL=PPL_PSOX("IRXN")_","
. E S PPL=PSOX("IRXN")_","
. Q
FINISHP I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=PSOX("IRXN")_",",RXFL(PSOX("IRXN"))=0 G FINISHX
F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1
I $L(PSORX("PSOL",PSOX2))+$L(PSOX("IRXN"))<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSOX("IRXN")_","
E S PSORX("PSOL",PSOX2+1)=PSOX("IRXN")_","
S RXFL(PSOX("IRXN"))=0
FINISHX ;
;call to build bingo board Rx array
S:'$G(PSORX("MAIL/WINDOW")) PSORX("MAIL/WINDOW")=$P(PSORENW("NRX0"),"^",11)
I $G(PSORX("MAIL/WINDOW"))["W" S BINGCRT=1,BINGRTE="W",BBFLG=1 D BBRX^PSORN52C
K PSOX1,PSOX2
Q
EOJ ;
L -^PSRX("B",PSOX("IRXN")) K PSORN52,PSOX("INS"),PSORENW("INS"),PSORXED("INS"),PSONEW("ENT"),PSORXED("ENT"),OLENT,PSOIBHLD,PSOX("SINS"),PSORENW("SINS"),PSORXED("SINS"),FILE
D PSOUL^PSSLOCK(PSOX("IRXN")) D PSOUL^PSSLOCK(PSOX("OIRXN"))
Q
MESS ;
I $G(PSOSCOTX)=1&(PSOSCP<50) W:$G(PSODRUG("DEA"))'["S"&($G(PSODRUG("DEA"))'["I") !!,"This Rx has been flagged by the provider as: "_$S($G(PSOSCOTH):"NO COPAY",$G(PSORX("SC"))="SC":"NO COPAY",1:"COPAY"),! S PSOSCOTX=2
Q
;IHS/CIA/PLS - 10/26/05 - Added new PEP
; Remove Chronic Med flag for discontinued meds
; FileMan will clean up the xref in ^PS(55,PSDFN,"P","CP",DA)
KILLOCM(DA) ;PEP - See above two lines for description
;Implementation moved to PSORN52A in patch 1010
D KILLOCM^PSORN52A(DA)
Q
PSORN52 ;BIR/DSD - files renewal entries in prescription file ;08-Apr-2014 13:51;DU
+1 ;;7.0;OUTPATIENT PHARMACY;**1,11,27,37,46,79,71,100,117,157,1005,143,219,148,239,201,225,303,1014,1017**;DEC 1997;Build 40
+2 ;Ext ref to ^PS(55 sup by DBIA 2228
+3 ;Ext ref to PSOUL^PSSLOCK sup by DBIA 2789
+4 ;Ext ref to ^VA(200 sup by DBIA 10060
+5 ;Ext ref to SWSTAT^IBBAPI sup by DBIA 4663
+6 ;
+7 ;Modified - IHS/CIA/PLS - 10/26/05 - New KILLOCM API
+8 ; IHS/MSC/PLS - 06/01/2010 - Line START+60
EN(PSOX) ;EP
START ;
+1 ; Start RT Mon
IF $DATA(XRTL)
DO T0^%ZOSV
+2 NEW PSOIBHLD,PSOSCOTH,PSOSCOTX
SET (PSOSCOTH,PSOSCOTX)=0
SET PSOIBHLD=""
IF $GET(PSOFDR)
IF $GET(ORD)
Begin DoDot:1
+3 SET PSOIBHLD=$SELECT($PIECE($GET(^PS(52.41,ORD,0)),"^",16)="SC":1,$PIECE($GET(^(0)),"^",16)="NSC":0,1:"")
+4 IF '$$DT^PSOMLLDT
QUIT
+5 NEW PSOIBHLX
SET PSOIBHLX=$GET(^PS(52.41,ORD,"IBQ"))
+6 SET PSOIBHLD=PSOIBHLD_"^"_$SELECT($PIECE(PSOIBHLX,"^")=1:1,$PIECE(PSOIBHLX,"^")=0:0,1:"")_"^"_$SELECT($PIECE(PSOIBHLX,"^",2)=1:1,$PIECE(PSOIBHLX,"^",2)=0:0,1:"")_"^"_$SELECT($PIECE(PSOIBHLX,"^",3)=1:1,$PIECE(PSOIBHLX,"^",3)=0:0,1:""
)
+7 SET PSOIBHLD=PSOIBHLD_"^"_$SELECT($PIECE(PSOIBHLX,"^",4)=1:1,$PIECE(PSOIBHLX,"^",4)=0:0,1:"")_"^"_$SELECT($PIECE(PSOIBHLX,"^",5)=1:1,$PIECE(PSOIBHLX,"^",5)=0:0,1:"")_"^"_$SELECT($PIECE(PSOIBHLX,"^",6)=1:1,$PIECE(PSOIBHLX,"^",6)=0:0,
1:"")
+8 SET PSOIBHLD=PSOIBHLD_"^"_$SELECT($PIECE(PSOIBHLX,"^",7)=1:1,$PIECE(PSOIBHLX,"^",7)=0:0,1:"")
+9 IF $PIECE(PSOIBHLX,"^")=1!($PIECE(PSOIBHLX,"^",2)=1)!($PIECE(PSOIBHLX,"^",3)=1)!($PIECE(PSOIBHLX,"^",4)=1)!($PIECE(PSOIBHLX,"^",5)=1)!($PIECE(PSOIBHLX,"^",6)=1)!($PIECE(PSOIBHLX,"^",7)=1)
SET PSOSCOTH=1
End DoDot:1
+10 IF $GET(PSOSCOTH)!($GET(PSORX("SC"))="SC")!($GET(PSORX("SC"))="NSC")
SET PSOSCOTX=1
+11 SET PSOANSQ("SC>50")=""
DO SCP^PSORN52D
+12 IF $GET(PSOFDR)
IF $GET(ORD)
IF $DATA(^PS(52.41,ORD,"ICD"))
SET FILE=52.41
DO GET^PSORN52D
+13 ;Set ans to renew from Rx, only if no ans from Pend file
+14 IF $GET(PSORENW("OIRXN"))
Begin DoDot:1
+15 NEW PSOLDIBQ
SET PSOLDIBQ=$GET(^PSRX(PSORENW("OIRXN"),"IBQ"))
+16 IF $PIECE(PSOIBHLD,"^")=""
Begin DoDot:2
+17 IF $PIECE($GET(^PSRX(PSORENW("OIRXN"),"IB")),"^")=2
SET $PIECE(PSOIBHLD,"^")=0
End DoDot:2
+18 IF '$$DT^PSOMLLDT
QUIT
+19 IF PSOLDIBQ=""
QUIT
+20 DO IBHLD^PSORN52A
End DoDot:1
+21 DO INIT
IF PSORN52("QFLG")
GOTO END
DO FILE^PSORN52A
+22 ; Stop RT Mon
IF $DATA(XRT0)
SET XRTN=$TEXT(+0)
IF $DATA(XRT0)
DO T1^%ZOSV
+23 KILL PSOANSQ,PSOANSQD,PSONEWFF
+24 IF $GET(PSOIBHLD)'=""
Begin DoDot:1
+25 ;Set answers based on Pend Renew, prior to Phar call
+26 IF '$GET(PSOX("IRXN"))
QUIT
+27 IF $PIECE(PSOIBHLD,"^")=1!($PIECE(PSOIBHLD,"^")=0)
SET PSOANSQ("SC")=$PIECE(PSOIBHLD,"^")
+28 IF '$$DT^PSOMLLDT
QUIT
+29 IF $PIECE(PSOIBHLD,"^",2)=1!($PIECE(PSOIBHLD,"^",2)=0)
SET PSOANSQ(PSOX("IRXN"),"MST")=$PIECE(PSOIBHLD,"^",2)
+30 IF $PIECE(PSOIBHLD,"^",3)=1!($PIECE(PSOIBHLD,"^",3)=0)
SET PSOANSQ(PSOX("IRXN"),"VEH")=$PIECE(PSOIBHLD,"^",3)
+31 IF $PIECE(PSOIBHLD,"^",4)=1!($PIECE(PSOIBHLD,"^",4)=0)
SET PSOANSQ(PSOX("IRXN"),"RAD")=$PIECE(PSOIBHLD,"^",4)
+32 IF $PIECE(PSOIBHLD,"^",5)=1!($PIECE(PSOIBHLD,"^",5)=0)
SET PSOANSQ(PSOX("IRXN"),"PGW")=$PIECE(PSOIBHLD,"^",5)
+33 IF $PIECE(PSOIBHLD,"^",6)=1!($PIECE(PSOIBHLD,"^",6)=0)
SET PSOANSQ(PSOX("IRXN"),"HNC")=$PIECE(PSOIBHLD,"^",6)
+34 IF $PIECE(PSOIBHLD,"^",7)=1!($PIECE(PSOIBHLD,"^",7)=0)
SET PSOANSQ(PSOX("IRXN"),"CV")=$PIECE(PSOIBHLD,"^",7)
+35 IF $PIECE(PSOIBHLD,"^",8)=1!($PIECE(PSOIBHLD,"^",8)=0)
SET PSOANSQ(PSOX("IRXN"),"SHAD")=$PIECE(PSOIBHLD,"^",8)
End DoDot:1
+36 KILL PSOIBHLD
+37 IF '$GET(PSOFDR)
IF $GET(PSORENW("OIRXN"))
SET FILE=52
DO GET^PSORN52D
+38 SET PSONEW("NEWCOPAY")=""
+39 IF (PSOSCP<50&('$PIECE($GET(^PS(53,+$PIECE(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7)))
IF $GET(DUZ("AG"))="V"
SET PSOFLAG=0
DO COPAY^PSOCPB
+40 ;I PSOSCP>49!($P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7)=1) S PSOFLAG=0 D SC^PSOMLLD2
+41 IF PSOSCA&(PSOSCP>49)!((PSOSCA!(PSOBILL=2))&($PIECE($GET(^PS(53,+$PIECE(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7)=1))
SET PSOFLAG=0
DO SC^PSOMLLD2
+42 IF $$DT^PSOMLLDT
Begin DoDot:1
+43 IF $DATA(PSOIBQS(PSODFN,"CV"))
DO MESS
DO CV^PSOMLLDT
IF $GET(PSOANSQ(PSOX("IRXN"),"CV"))
KILL PSONEW("NEWCOPAY")
+44 IF $DATA(PSOIBQS(PSODFN,"VEH"))
DO MESS
DO VEH^PSOMLLDT
IF $GET(PSOANSQ(PSOX("IRXN"),"VEH"))
KILL PSONEW("NEWCOPAY")
+45 IF $DATA(PSOIBQS(PSODFN,"RAD"))
DO MESS
DO RAD^PSOMLLDT
IF $GET(PSOANSQ(PSOX("IRXN"),"RAD"))
KILL PSONEW("NEWCOPAY")
+46 IF $DATA(PSOIBQS(PSODFN,"PGW"))
DO MESS
DO PGW^PSOMLLDT
IF $GET(PSOANSQ(PSOX("IRXN"),"PGW"))
KILL PSONEW("NEWCOPAY")
+47 IF $DATA(PSOIBQS(PSODFN,"SHAD"))
DO MESS
DO SHAD^PSOMLLD2
IF $GET(PSOANSQ(PSOX("IRXN"),"SHAD"))
KILL PSONEW("NEWCOPAY")
+48 IF $DATA(PSOIBQS(PSODFN,"MST"))
DO MESS
DO MST^PSOMLLDT
IF $GET(PSOANSQ(PSOX("IRXN"),"MST"))
KILL PSONEW("NEWCOPAY")
+49 IF $DATA(PSOIBQS(PSODFN,"HNC"))
DO MESS
DO HNC^PSOMLLDT
IF $GET(PSOANSQ(PSOX("IRXN"),"HNC"))
KILL PSONEW("NEWCOPAY")
End DoDot:1
+50 KILL PSOSCOTH,PSOSCOTX
+51 IF $GET(PSONEW("NEWCOPAY"))
SET ^PSRX(PSOX("IRXN"),"IB")=PSONEW("NEWCOPAY")
+52 ;
+53 DO FINISH
DO ACP^PSOUTIL
+54 ;
+55 NEW PSOSCFLD
SET PSOSCFLD=$SELECT(PSOSCP'="":$GET(PSOANSQ("SC")),1:"")_"^"_$GET(PSOANSQ(PSOX("IRXN"),"MST"))_"^"_$GET(PSOANSQ(PSOX("IRXN"),"VEH"))_"^"_$GET(PSOANSQ(PSOX("IRXN"),"RAD"))
+56 SET PSOSCFLD=PSOSCFLD_"^"_$GET(PSOANSQ(PSOX("IRXN"),"PGW"))_"^"_$GET(PSOANSQ(PSOX("IRXN"),"HNC"))_"^"_$GET(PSOANSQ(PSOX("IRXN"),"CV"))_"^"_$GET(PSOANSQ(PSOX("IRXN"),"SHAD"))
+57 IF PSOSCP<50&($TRANSLATE(PSOSCFLD,"^")'="")&('$PIECE($GET(^PS(53,+$PIECE(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7))
SET ^PSRX(PSOX("IRXN"),"IBQ")=PSOSCFLD
KILL PSOSCFLD
+58 ;
+59 DO FILE2^PSORN52D
+60 ;IHS/MSC/PLS - 06/01/2010
+61 ;D:$$SWSTAT^IBBAPI() GACT^PSOPFSU0(PSOX("IRXN"),0)
+62 KILL PSONEW("NEWCOPAY"),PSOANSQ
END DO EOJ
+1 QUIT
INIT SET PSORN52("QFLG")=0
IF '$DATA(PSOX("DAYS SUPPLY"))
SET PSOX("DAYS SUPPLY")=$PIECE(PSOX("RX0"),"^",8)
+1 IF '$DATA(PSOX("# OF REFILLS"))
SET PSOX("# OF REFILLS")=$PIECE(PSOX("RX0"),"^",9)
IF '$DATA(PSOX("ISSUE DATE"))
SET PSOX("ISSUE DATE")=DT
+2 ;IHS/MSC/MGH Set NDC code from drug file
+3 IF '$DATA(PSOX("NDC"))
SET PSOX("NDC")=$$NDCFMT^PSSNDCUT($$GET1^DIQ(50,+$GET(PSOX("DRUG IEN")),31))
+4 DO INIT^PSON52
KILL PSON52
+5 QUIT
+6 ;
FINISH ;
+1 IF PSOX("STATUS")=4
GOTO FINISHP
+2 IF $DATA(PSORX("VERIFY"))
Begin DoDot:1
+3 KILL DIC,DLAYGO,DINUM,DIADD,X,DD,DO
SET DIC="^PS(52.4,"
SET DLAYGO=52.4
SET DINUM=PSOX("IRXN")
SET DIC(0)="ML"
+4 SET X=PSOX("IRXN")
DO FILE^DICN
KILL DD,DO,DIC,DLAYGO,DINUM,X
+5 SET ^PS(52.4,PSOX("IRXN"),0)=PSOX("IRXN")_"^"_$PIECE(PSOX("NRX0"),"^",2)_"^"_DUZ_"^"_$GET(PSOX("OIRXN"))_"^"_$EXTRACT(PSOX("LOGIN DATE"),1,7)_"^"_PSOX("IRXN")_"^"_PSOX("STOP DATE")
+6 KILL DIK,DA
SET DIK="^PS(52.4,"
SET DA=PSOX("IRXN")
DO IX^DIK
KILL DIK,DA
End DoDot:1
GOTO FINISHX
+7 ;
+8 IF $GET(PSOX("QS"))="S"
IF $GET(PSOBARCD)
SET DA=PSOX("IRXN")
SET RXFL(PSOX("IRXN"))=0
DO SUS^PSORXL
KILL DA
GOTO FINISHX
+9 ;
+10 IF PSOX("FILL DATE")>DT
IF $PIECE(PSOPAR,"^",6)
SET DA=PSOX("IRXN")
SET RXFL(PSOX("IRXN"))=0
DO SUS^PSORXL
KILL DA
GOTO FINISHX
+11 ;
+12 ; - Submitting Rx to ECME for 3rd Party Billing
+13 NEW ACTION
+14 IF $$SUBMIT^PSOBPSUT(PSOX("IRXN"),0)
Begin DoDot:1
+15 SET ACTION=""
DO ECMESND^PSOBPSU1(PSOX("IRXN"),0,PSOX("FILL DATE"),"RN")
+16 IF $$FIND^PSOREJUT(PSOX("IRXN"),0)
Begin DoDot:2
+17 SET ACTION=$$HDLG^PSOREJU1(PSOX("IRXN"),0,"79,88","RN","IOQ","Q")
End DoDot:2
End DoDot:1
IF ACTION="Q"!(ACTION="^")
QUIT
+18 ;
+19 IF $GET(PSOX("QS"))="Q"
IF $GET(PSOBARCD)
Begin DoDot:1
+20 NEW PSOFROM
SET PSOFROM="BATCH"
IF $GET(PPL)
IF $LENGTH(PPL_PSOX("IRXN")_",")>240
DO TRI^PSOBBC
DO Q^PSORXL
KILL PPL,RXFL
+21 SET RXFL(PSOX("IRXN"))=0
+22 IF $GET(PPL)
SET PPL=PPL_PSOX("IRXN")_","
+23 IF '$TEST
SET PPL=PSOX("IRXN")_","
+24 QUIT
End DoDot:1
GOTO FINISHX
FINISHP IF $GET(PSORX("PSOL",1))']""
SET PSORX("PSOL",1)=PSOX("IRXN")_","
SET RXFL(PSOX("IRXN"))=0
GOTO FINISHX
+1 FOR PSOX1=0:0
SET PSOX1=$ORDER(PSORX("PSOL",PSOX1))
IF 'PSOX1
QUIT
SET PSOX2=PSOX1
+2 IF $LENGTH(PSORX("PSOL",PSOX2))+$LENGTH(PSOX("IRXN"))<220
SET PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSOX("IRXN")_","
+3 IF '$TEST
SET PSORX("PSOL",PSOX2+1)=PSOX("IRXN")_","
+4 SET RXFL(PSOX("IRXN"))=0
FINISHX ;
+1 ;call to build bingo board Rx array
+2 IF '$GET(PSORX("MAIL/WINDOW"))
SET PSORX("MAIL/WINDOW")=$PIECE(PSORENW("NRX0"),"^",11)
+3 IF $GET(PSORX("MAIL/WINDOW"))["W"
SET BINGCRT=1
SET BINGRTE="W"
SET BBFLG=1
DO BBRX^PSORN52C
+4 KILL PSOX1,PSOX2
+5 QUIT
EOJ ;
+1 LOCK -^PSRX("B",PSOX("IRXN"))
KILL PSORN52,PSOX("INS"),PSORENW("INS"),PSORXED("INS"),PSONEW("ENT"),PSORXED("ENT"),OLENT,PSOIBHLD,PSOX("SINS"),PSORENW("SINS"),PSORXED("SINS"),FILE
+2 DO PSOUL^PSSLOCK(PSOX("IRXN"))
DO PSOUL^PSSLOCK(PSOX("OIRXN"))
+3 QUIT
MESS ;
+1 IF $GET(PSOSCOTX)=1&(PSOSCP<50)
IF $GET(PSODRUG("DEA"))'["S"&($GET(PSODRUG("DEA"))'["I")
WRITE !!,"This Rx has been flagged by the provider as: "_$SELECT($GET(PSOSCOTH):"NO COPAY",$GET(PSORX("SC"))="SC":"NO COPAY",1:"COPAY"),!
SET PSOSCOTX=2
+2 QUIT
+3 ;IHS/CIA/PLS - 10/26/05 - Added new PEP
+4 ; Remove Chronic Med flag for discontinued meds
+5 ; FileMan will clean up the xref in ^PS(55,PSDFN,"P","CP",DA)
KILLOCM(DA) ;PEP - See above two lines for description
+1 ;Implementation moved to PSORN52A in patch 1010
+2 DO KILLOCM^PSORN52A(DA)
+3 QUIT
