Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSORN52

PSORN52.m

Go to the documentation of this file.
  1. 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
  1. ;Ext ref to PSOUL^PSSLOCK sup by DBIA 2789
  1. ;Ext ref to SWSTAT^IBBAPI sup by DBIA 4663
  1. EN(PSOX) ;EP
  1. START ;
  1. D:$D(XRTL) T0^%ZOSV ; Start RT Mon
  1. N PSOIBHLD,PSOSCOTH,PSOSCOTX S (PSOSCOTH,PSOSCOTX)=0 S PSOIBHLD="" I $G(PSOFDR),$G(ORD) D
  1. .S PSOIBHLD=$S($P($G(^PS(52.41,ORD,0)),"^",16)="SC":1,$P($G(^(0)),"^",16)="NSC":0,1:"")
  1. .I '$$DT^PSOMLLDT Q
  1. .N PSOIBHLX S PSOIBHLX=$G(^PS(52.41,ORD,"IBQ"))
  1. .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:"")
  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:"")
  1. .S PSOIBHLD=PSOIBHLD_"^"_$S($P(PSOIBHLX,"^",7)=1:1,$P(PSOIBHLX,"^",7)=0:0,1:"")
  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
  1. I $G(PSOSCOTH)!($G(PSORX("SC"))="SC")!($G(PSORX("SC"))="NSC") S PSOSCOTX=1
  1. S PSOANSQ("SC>50")="" D SCP^PSORN52D
  1. I $G(PSOFDR),$G(ORD) I $D(^PS(52.41,ORD,"ICD")) S FILE=52.41 D GET^PSORN52D
  1. ;Set ans to renew from Rx, only if no ans from Pend file
  1. I $G(PSORENW("OIRXN")) D
  1. .N PSOLDIBQ S PSOLDIBQ="" ;*362 ;do not copy over IBQ node for a renewal
  1. .I $P(PSOIBHLD,"^")="" D
  1. ..I $P($G(^PSRX(PSORENW("OIRXN"),"IB")),"^")=2 S $P(PSOIBHLD,"^")=0
  1. .I '$$DT^PSOMLLDT Q
  1. .I PSOLDIBQ="" Q
  1. .D IBHLD^PSORN52A
  1. D INIT G:PSORN52("QFLG") END D FILE^PSORN52A
  1. S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV ; Stop RT Mon
  1. K PSOANSQ,PSOANSQD,PSONEWFF
  1. I $G(PSOIBHLD)'="" D
  1. .;Set answers based on Pend Renew, prior to Phar call
  1. .Q:'$G(PSOX("IRXN"))
  1. .I $P(PSOIBHLD,"^")=1!($P(PSOIBHLD,"^")=0) S PSOANSQ("SC")=$P(PSOIBHLD,"^")
  1. .I '$$DT^PSOMLLDT Q
  1. .I $P(PSOIBHLD,"^",2)=1!($P(PSOIBHLD,"^",2)=0) S PSOANSQ(PSOX("IRXN"),"MST")=$P(PSOIBHLD,"^",2)
  1. .I $P(PSOIBHLD,"^",3)=1!($P(PSOIBHLD,"^",3)=0) S PSOANSQ(PSOX("IRXN"),"VEH")=$P(PSOIBHLD,"^",3)
  1. .I $P(PSOIBHLD,"^",4)=1!($P(PSOIBHLD,"^",4)=0) S PSOANSQ(PSOX("IRXN"),"RAD")=$P(PSOIBHLD,"^",4)
  1. .I $P(PSOIBHLD,"^",5)=1!($P(PSOIBHLD,"^",5)=0) S PSOANSQ(PSOX("IRXN"),"PGW")=$P(PSOIBHLD,"^",5)
  1. .I $P(PSOIBHLD,"^",6)=1!($P(PSOIBHLD,"^",6)=0) S PSOANSQ(PSOX("IRXN"),"HNC")=$P(PSOIBHLD,"^",6)
  1. .I $P(PSOIBHLD,"^",7)=1!($P(PSOIBHLD,"^",7)=0) S PSOANSQ(PSOX("IRXN"),"CV")=$P(PSOIBHLD,"^",7)
  1. .I $P(PSOIBHLD,"^",8)=1!($P(PSOIBHLD,"^",8)=0) S PSOANSQ(PSOX("IRXN"),"SHAD")=$P(PSOIBHLD,"^",8)
  1. K PSOIBHLD
  1. I '$G(PSOFDR) I $G(PSORENW("OIRXN")) S FILE=52 D GET^PSORN52D
  1. S PSONEW("NEWCOPAY")=""
  1. 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
  1. ;I PSOSCP>49!($P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7)=1) S PSOFLAG=0 D SC^PSOMLLD2
  1. 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
  1. I $$DT^PSOMLLDT D
  1. .I $D(PSOIBQS(PSODFN,"CV")) D MESS D CV^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"CV")) K PSONEW("NEWCOPAY")
  1. .I $D(PSOIBQS(PSODFN,"VEH")) D MESS D VEH^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"VEH")) K PSONEW("NEWCOPAY")
  1. .I $D(PSOIBQS(PSODFN,"RAD")) D MESS D RAD^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"RAD")) K PSONEW("NEWCOPAY")
  1. .I $D(PSOIBQS(PSODFN,"PGW")) D MESS D PGW^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"PGW")) K PSONEW("NEWCOPAY")
  1. .I $D(PSOIBQS(PSODFN,"SHAD")) D MESS D SHAD^PSOMLLD2 I $G(PSOANSQ(PSOX("IRXN"),"SHAD")) K PSONEW("NEWCOPAY")
  1. .I $D(PSOIBQS(PSODFN,"MST")) D MESS D MST^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"MST")) K PSONEW("NEWCOPAY")
  1. .I $D(PSOIBQS(PSODFN,"HNC")) D MESS D HNC^PSOMLLDT I $G(PSOANSQ(PSOX("IRXN"),"HNC")) K PSONEW("NEWCOPAY")
  1. K PSOSCOTH,PSOSCOTX
  1. I $G(PSONEW("NEWCOPAY")) S ^PSRX(PSOX("IRXN"),"IB")=PSONEW("NEWCOPAY")
  1. ;
  1. D FINISH,ACP^PSOUTIL
  1. ;
  1. I $G(PSOX("MAIL/WINDOW"))="P" D PARK^PSOPRKA(PSOX("IRXN")),RMP^PSOPRKA(PSOX("IRXN")) ;441 PAPI
  1. ;
  1. 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"))
  1. S PSOSCFLD=PSOSCFLD_"^"_$G(PSOANSQ(PSOX("IRXN"),"PGW"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"HNC"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"CV"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"SHAD"))
  1. 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
  1. ;
  1. D FILE2^PSORN52D
  1. D:$$SWSTAT^IBBAPI() GACT^PSOPFSU0(PSOX("IRXN"),0)
  1. K PSONEW("NEWCOPAY"),PSOANSQ
  1. END D EOJ
  1. Q
  1. INIT S PSORN52("QFLG")=0 S:'$D(PSOX("DAYS SUPPLY")) PSOX("DAYS SUPPLY")=$P(PSOX("RX0"),"^",8)
  1. S:'$D(PSOX("# OF REFILLS")) PSOX("# OF REFILLS")=$P(PSOX("RX0"),"^",9) S:'$D(PSOX("ISSUE DATE")) PSOX("ISSUE DATE")=DT
  1. D INIT^PSON52 K PSON52
  1. Q
  1. ;
  1. FINISH ;
  1. N PSOTFIN
  1. I '$D(^XUSEC("PSORPH",DUZ)) S PSOTFIN="",PSOTFIN=$$TECH2^PSODGDGP(PSOX("IRXN"),PSODFN,DUZ,.PSOX)
  1. I '$D(^XUSEC("PSORPH",DUZ)) G FINISHP:$G(PSOTFIN)=1 G FINISHX:$G(PSOTFIN)=2
  1. ;
  1. 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
  1. ;
  1. 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
  1. ;
  1. ; - Submitting Rx to ECME for 3rd Party Billing
  1. N ACTION
  1. I $$SUBMIT^PSOBPSUT(PSOX("IRXN"),0) D I ACTION="Q"!(ACTION="^") Q
  1. . S ACTION="" D ECMESND^PSOBPSU1(PSOX("IRXN"),0,"","RN")
  1. .; Quit if there is an unresolved Tricare/CHAMPVA non-billable reject code, PSO*7*358
  1. . I $$PSOET^PSOREJP3(PSOX("IRXN"),0) S ACTION="Q" Q
  1. . I $$FIND^PSOREJUT(PSOX("IRXN"),0) D
  1. . . S ACTION=$$HDLG^PSOREJU1(PSOX("IRXN"),0,"79,88,943","RN","IOQ","Q")
  1. ;
  1. I $G(PSOX("QS"))="Q",$G(PSOBARCD) D G FINISHX
  1. . N PSOFROM S PSOFROM="BATCH" I $G(PPL),$L(PPL_PSOX("IRXN")_",")>240 D TRI^PSOBBC D Q^PSORXL K PPL,RXFL
  1. .S RXFL(PSOX("IRXN"))=0
  1. . I $G(PPL) S PPL=PPL_PSOX("IRXN")_","
  1. . E S PPL=PSOX("IRXN")_","
  1. . Q
  1. FINISHP I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=PSOX("IRXN")_",",RXFL(PSOX("IRXN"))=0 G FINISHX
  1. F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1
  1. I $L(PSORX("PSOL",PSOX2))+$L(PSOX("IRXN"))<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSOX("IRXN")_","
  1. E S PSORX("PSOL",PSOX2+1)=PSOX("IRXN")_","
  1. S RXFL(PSOX("IRXN"))=0
  1. FINISHX ;
  1. ;call to build bingo board Rx array
  1. S:'$G(PSORX("MAIL/WINDOW")) PSORX("MAIL/WINDOW")=$P(PSORENW("NRX0"),"^",11)
  1. I $G(PSORX("MAIL/WINDOW"))["W" S BINGCRT=1,BINGRTE="W",BBFLG=1 D BBRX^PSORN52C
  1. K PSOX1,PSOX2,^TMP("PSODOSF",$J)
  1. Q
  1. EOJ ;
  1. 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
  1. D PSOUL^PSSLOCK(PSOX("IRXN")) D PSOUL^PSSLOCK(PSOX("OIRXN"))
  1. Q
  1. MESS ;
  1. 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
  1. Q