- PSORN52 ;BIR/DSD - files renewal entries in prescription file ;Jan 20, 2022@11:20:47
- ;;7.0;OUTPATIENT PHARMACY;**1,11,27,37,46,79,71,100,117,157,143,219,148,239,201,225,303,358,251,387,379,362,514,562,441**;DEC 1997;Build 208
- ;Ext ref to PSOUL^PSSLOCK sup by DBIA 2789
- ;Ext ref to SWSTAT^IBBAPI sup by DBIA 4663
- 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="" ;*362 ;do not copy over IBQ node for a renewal
- .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 W:'$G(PSOSPRNW) @IOF D SC^PSOMLLD2 ;*514
- 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
- ;
- I $G(PSOX("MAIL/WINDOW"))="P" D PARK^PSOPRKA(PSOX("IRXN")),RMP^PSOPRKA(PSOX("IRXN")) ;441 PAPI
- ;
- 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
- 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
- D INIT^PSON52 K PSON52
- Q
- ;
- FINISH ;
- N PSOTFIN
- I '$D(^XUSEC("PSORPH",DUZ)) S PSOTFIN="",PSOTFIN=$$TECH2^PSODGDGP(PSOX("IRXN"),PSODFN,DUZ,.PSOX)
- I '$D(^XUSEC("PSORPH",DUZ)) G FINISHP:$G(PSOTFIN)=1 G FINISHX:$G(PSOTFIN)=2
- ;
- I $G(PSOX("QS"))="S",$G(PSOBARCD),$G(PSOX("MAIL/WINDOW"))'="P" S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=0 D SUS^PSORXL K DA G FINISHX
- ;
- I PSOX("FILL DATE")>DT,$P(PSOPAR,"^",6),$G(PSOX("MAIL/WINDOW"))'="P" 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,"","RN")
- .; Quit if there is an unresolved Tricare/CHAMPVA non-billable reject code, PSO*7*358
- . I $$PSOET^PSOREJP3(PSOX("IRXN"),0) S ACTION="Q" Q
- . I $$FIND^PSOREJUT(PSOX("IRXN"),0) D
- . . S ACTION=$$HDLG^PSOREJU1(PSOX("IRXN"),0,"79,88,943","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,^TMP("PSODOSF",$J)
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORN52 7431 printed Jan 18, 2025@03:35:14 Page 2
- PSORN52 ;BIR/DSD - files renewal entries in prescription file ;Jan 20, 2022@11:20:47
- +1 ;;7.0;OUTPATIENT PHARMACY;**1,11,27,37,46,79,71,100,117,157,143,219,148,239,201,225,303,358,251,387,379,362,514,562,441**;DEC 1997;Build 208
- +2 ;Ext ref to PSOUL^PSSLOCK sup by DBIA 2789
- +3 ;Ext ref to SWSTAT^IBBAPI sup by DBIA 4663
- 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 ;*362 ;do not copy over IBQ node for a renewal
- NEW PSOLDIBQ
- SET PSOLDIBQ=""
- +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 ;*514
- IF PSOSCA&(PSOSCP>49)!((PSOSCA!(PSOBILL=2))&($PIECE($GET(^PS(53,+$PIECE(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7)=1))
- SET PSOFLAG=0
- if '$GET(PSOSPRNW)
- WRITE @IOF
- 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 ;441 PAPI
- IF $GET(PSOX("MAIL/WINDOW"))="P"
- DO PARK^PSOPRKA(PSOX("IRXN"))
- DO RMP^PSOPRKA(PSOX("IRXN"))
- +56 ;
- +57 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"))
- +58 SET PSOSCFLD=PSOSCFLD_"^"_$GET(PSOANSQ(PSOX("IRXN"),"PGW"))_"^"_$GET(PSOANSQ(PSOX("IRXN"),"HNC"))_"^"_$GET(PSOANSQ(PSOX("IRXN"),"CV"))_"^"_$GET(PSOANSQ(PSOX("IRXN"),"SHAD"))
- +59 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
- +60 ;
- +61 DO FILE2^PSORN52D
- +62 if $$SWSTAT^IBBAPI()
- DO GACT^PSOPFSU0(PSOX("IRXN"),0)
- +63 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 DO INIT^PSON52
- KILL PSON52
- +3 QUIT
- +4 ;
- FINISH ;
- +1 NEW PSOTFIN
- +2 IF '$DATA(^XUSEC("PSORPH",DUZ))
- SET PSOTFIN=""
- SET PSOTFIN=$$TECH2^PSODGDGP(PSOX("IRXN"),PSODFN,DUZ,.PSOX)
- +3 IF '$DATA(^XUSEC("PSORPH",DUZ))
- if $GET(PSOTFIN)=1
- GOTO FINISHP
- if $GET(PSOTFIN)=2
- GOTO FINISHX
- +4 ;
- +5 IF $GET(PSOX("QS"))="S"
- IF $GET(PSOBARCD)
- IF $GET(PSOX("MAIL/WINDOW"))'="P"
- SET DA=PSOX("IRXN")
- SET RXFL(PSOX("IRXN"))=0
- DO SUS^PSORXL
- KILL DA
- GOTO FINISHX
- +6 ;
- +7 IF PSOX("FILL DATE")>DT
- IF $PIECE(PSOPAR,"^",6)
- IF $GET(PSOX("MAIL/WINDOW"))'="P"
- SET DA=PSOX("IRXN")
- SET RXFL(PSOX("IRXN"))=0
- DO SUS^PSORXL
- KILL DA
- GOTO FINISHX
- +8 ;
- +9 ; - Submitting Rx to ECME for 3rd Party Billing
- +10 NEW ACTION
- +11 IF $$SUBMIT^PSOBPSUT(PSOX("IRXN"),0)
- Begin DoDot:1
- +12 SET ACTION=""
- DO ECMESND^PSOBPSU1(PSOX("IRXN"),0,"","RN")
- +13 ; Quit if there is an unresolved Tricare/CHAMPVA non-billable reject code, PSO*7*358
- +14 IF $$PSOET^PSOREJP3(PSOX("IRXN"),0)
- SET ACTION="Q"
- QUIT
- +15 IF $$FIND^PSOREJUT(PSOX("IRXN"),0)
- Begin DoDot:2
- +16 SET ACTION=$$HDLG^PSOREJU1(PSOX("IRXN"),0,"79,88,943","RN","IOQ","Q")
- End DoDot:2
- End DoDot:1
- IF ACTION="Q"!(ACTION="^")
- QUIT
- +17 ;
- +18 IF $GET(PSOX("QS"))="Q"
- IF $GET(PSOBARCD)
- Begin DoDot:1
- +19 NEW PSOFROM
- SET PSOFROM="BATCH"
- IF $GET(PPL)
- IF $LENGTH(PPL_PSOX("IRXN")_",")>240
- DO TRI^PSOBBC
- DO Q^PSORXL
- KILL PPL,RXFL
- +20 SET RXFL(PSOX("IRXN"))=0
- +21 IF $GET(PPL)
- SET PPL=PPL_PSOX("IRXN")_","
- +22 IF '$TEST
- SET PPL=PSOX("IRXN")_","
- +23 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,^TMP("PSODOSF",$JOB)
- +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