PSOCP ;BIR/BAB - Pharmacy CO-PAY Application Utilities for IB ;02/06/92
;;7.0;OUTPATIENT PHARMACY;**20,46,71,85,137,157,143,219,239,201,225,303,460,480,485**;DEC 1997;Build 37
;
;REF/IA - IBARX/125, SDCO22/1579, PS(55/2228, PSDRUG(/221, DGMSTAPI/2716, $$GETSHAD^DGUTL3/4462
;Reference to $$CPTIER^PSNAPIS(P1,P3) supported by DBIA #2531
;Reference to $$GETSTAT^DGMSTAPI supported by DBIA 3457
;
CP ;Check if COPAY-Requires RXP,PSOSITE7
I '$D(PSOPAR) D ^PSOLSET G CP
K PSOCP
S PSOCPN=$P(^PSRX(RXP,0),"^",2) ; Set COPAY dfn PTR TO PATIENT
S PSOCP=$P($G(^PSRX(RXP,"IB")),"^") ; IB action type
S PSOSAVE=$S(PSOCP:1,1:"") ; save current copay status
; Set x=service^dfn^actiontype^user duz
I +$G(PSOSITE7)'>0 S PSOSITE7=$P(^PS(59,PSOSITE,"IB"),"^")
S X=PSOSITE7_"^"_PSOCPN_"^"_PSOCP_"^"_$P(^PSRX(RXP,0),"^",16)
;
RX ;Determine Orig or Refill for RX
N PSOIB,PSOPFS,PSOCPT S (PSOIB,PSOREF)=0
I $G(^PSRX(RXP,1,+$G(YY),0))]"" S PSOREF=YY
D PFSA^PSOPFSU1(RXP,PSOREF,2) G PFS:+PSOPFS
; Check if bill exists
I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",2)>0 D CHKIB^PSOCP1 I PSOIB G QUIT
I 'PSOREF,+$P($G(^PSRX(RXP,"IB")),"^",4)>0 G QUIT ; 'POTENTIAL BILL' - ALREADY ATTEMPTED TO BILL, BUT EXCEEDED ANNUAL COPAY CAP
I PSOREF,+$G(^PSRX(RXP,1,PSOREF,"IB")) D CHKIB^PSOCP1 I PSOIB G QUIT
I PSOREF,+$P($G(^PSRX(RXP,1,PSOREF,"IB")),"^",2) G QUIT ; POTENTIAL BILL
PFS ;
S PSOCHG=1 ; set tem var to copay and check exception
N MAILMSG
D COPAYREL
I 'PSOCHG D D:PSOPFS CHRG^PSOPFSU1(RXP,PSOREF,"CG",PSOPFS) G QUIT
. I PSOSAVE S PSODA=RXP,PREA="R" D ACTLOG^PSOCPA S $P(^PSRX(RXP,"IB"),"^",1)=""
I PSOCHG=2 D I 'PSOCP D:PSOPFS CHRG^PSOPFSU1(RXP,PSOREF,"CG",PSOPFS) G QUIT ; IF 'SC' QUESTION APPLIES, BUT HAS NOT BEEN ANSWERED, SEND MAIL MSG AND KEEP COPAY STATUS AS IT WAS
. D MAIL2^PSOCPE ; SEND MAIL TO PHARMACIST, PROVIDER, AND HOLDERS OF THE PSO COPAY KEY
I PSOCHG=1,PSOSAVE="" D I PSOREF S PSOCOMM="",PSOOLD="No Copay",PSONW="Copay" S PSODA=RXP,PREA="R" D ACTLOG^PSOCPA
. I '$D(^PSRX(RXP,"IB")),'PSOREF S $P(^PSRX(RXP,"IB"),"^",1)=1 Q
. S $P(^PSRX(RXP,"IB"),"^",1)=1
. S PSOCP=1,$P(X,"^",3)=PSOCP
I PSOCHG'=2 I $G(MAILMSG) D MAIL2^PSOCPE ; SEND MAIL TO PHARM, PROV, AND HOLDERS OF PSO COPAY KEY HOLDERS
; Units for COPAY
S PSOCPUN=$P(($P(^PSRX(RXP,0),"^",8)+29)/30,".",1)
; Build softlink for x(n)=softlink^units
S X(1)="52:"_RXP S:PSOREF>0 X(1)=X(1)_";1:"_PSOREF S X(1)=X(1)_"^"_PSOCPUN
; Set correct user duz if refill
I PSOREF S:+$P(^PSRX(RXP,1,PSOREF,0),"^",7)>0 $P(X,"^",4)=$P(^PSRX(RXP,1,PSOREF,0),"^",7)
;
IBNEW ; Load ^TMP global for IB call
Q:$G(RXP)'>0
I PSOPFS D CHRG^PSOPFSU1(RXP,PSOREF,"CG",PSOPFS)
G QUIT:PSOPFS
N D0
G QUIT:'$D(X)
S XTMP=X,XTMP(1)=X(1)
;
; Requires x=service^dfn^action type^user duz
; x(n)=softlink^units
I $P(X,"^",3)="" S $P(X,"^",3)=$P(^PSRX(RXP,"IB"),"^",1)
D NEW^IBARX
; Returns y=1^total charges for this group or Y=-1^error code
; y(n)=IB number^charge for this Rx^AR bill #^Cap met^Partial or Full charge^Copay Exempt^Number from file 354.71
; Cap met ('1' - If patient has met cap amount or reached cap with this charge or '0' if not)
; Partial or Full ('P' for partial billing, 'F' for full billing, null for no billing)
; Copay Exempt - ('1' for exempt, '0' for non-exempt, '-1' for copay off (manila)),
; ('1' - If patient has met cap amount or reach cap with this charge
; Entry from file 354.71 will only be saved for fills that met the annual cap and could not be fully billed
;
G QUIT:+Y=-1
S XTMP=XTMP_"^"_Y,XTMP(1)=XTMP(1)_"^"_Y(1)
;
; see if exempt or copay cap was met
I $P(Y(1),"^",6) D G QUIT
. S PREA="R",PSOOLD="Copay",PSONW="No Copay"
. S PSOCOMM="RX COPAY INCOME EXEMPTION" S PSODA=RXP D ACTLOG^PSOCPA
. S $P(^PSRX(RXP,"IB"),"^",1)=""
I $P(Y(1),"^",4) D
. S PSOCOMM=$S($P(Y(1),"^",5)="F":" FULL BILLING FOR THIS FILL",$P(Y(1),"^",5)="P":" PARTIAL BILLING FOR THIS FILL ",1:" NO BILLING FOR THIS FILL")
. S PREA="A"
. S PSODA=RXP D ACTLOG^PSOCPA
. I $P(Y(1),"^",5)'="F" D
. . I PSOREF S $P(^PSRX(RXP,1,PSOREF,"IB"),"^",2)=$P(Y(1),"^",7) Q
. . S $P(^PSRX(RXP,"IB"),"^",4)=$P(Y(1),"^",7)
I $P(Y(1),"^",1)="" G QUIT
;
FILE ;File IB number in ^PSRX
S PSOCP2=0
S PSOCP2=+$P(XTMP(1),":",3)
S:PSOCP2>0 ^PSRX(RXP,1,PSOCP2,"IB")=$P(XTMP(1),U,3) ; Filing in refill node
I PSOCP2>0,'$D(^PSRX(RXP,"IB")) S ^PSRX(RXP,"IB")="1^^" ; If refill "IB" exists, need "IB" entry on original fill node
S:PSOCP2=0 $P(^PSRX(RXP,"IB"),"^",2)=$P(XTMP(1),U,3) ;Filing in original fill (zero node)
QUIT ;
K Y,PSOCP1,PSOCP2,QQ,PSOCPN,X,X2,XTMP,PSOCPUN,PSOREF,PSOCHG,PSOSAVE,PSOCOMM,PSOOLD,PSONW,PREA,PSORSN
Q
EN D ^PSOLSET
EN1 S DIR(0)="NO",DIR("A")="Enter PRESCRIPTION number" D ^DIR K DIR G:$D(DIRUT) EXIT S RXP=X I +$G(^PSRX(RXP,0))'>0!+$P($G(^PSRX(RXP,"IB")),"^",0)>0 W !,?10,"RE-CHECK PRESCRIPTION NUMBER AND RE-ENTER " G EN1
S PSOSITE7=$P(^PS(59,PSOSITE,"IB"),"^")
S PSODFN=$P(^PSRX(RXP,0),"^",2)
D CP G EN1
EXIT K RXP D FINAL^PSOLSET Q
;
SC(PSODFN,PSODD) ;sup ref for CPRS, Pre-Copay enhancement
N PSOSC
I $$DT^PSOMLLDT S PSOSC="" G SCQ
I $G(PSODD),($P($G(^PSDRUG(PSODD,0)),"^",3)["S")!($P($G(^(0)),"^",3)["I")!($P($G(^(0)),"^",3)["N") S PSOSC=1 G SCQ
I $P($G(^PS(55,+$G(PSODFN),"PS")),"^"),$P($G(^PS(53,+$P(^("PS"),"^"),0)),"^",7) S PSOSC=1 G SCQ
N I,J,X S (X,PSOSC)=""
S J=0 F S J=$O(^PS(59,J)) Q:'J I +$G(^(J,"IB")) S X=+^("IB") Q
G:'X SCQ
S X=X_"^"_PSODFN D XTYPE^IBARX
S J="" F S J=$O(Y(J)) Q:'J S I="" F S I=$O(Y(J,I)) Q:I="" S:I>0 PSOSC=I
SCQ Q $S($G(PSOSC)=2:0,1:1)
;
COPAYREL ; Recheck copay status at release
; check Rx patient status
I $P(^PSRX(RXP,0),"^",3)'="",$P($G(^PS(53,$P(^PSRX(RXP,0),"^",3),0)),"^",7)=1 S PSOCHG=0,PSOCOMM="Rx Patient Status Change",PSOOLD="Copay",PSONW="No Copay" Q
; see if drug is nutritional supplement, investigational or supply
N DRG,DRGTYP,X,PSOEXMPT
S DRG=+$P(^PSRX(RXP,0),"^",6),DRGTYP=$P($G(^PSDRUG(DRG,0)),"^",3)
I DRGTYP["I" S PSOCOMM="Investigational Drug",PSOOLD="Copay",PSONW="No Copay",PSOCHG=0,PSOEXMPT=1
I DRGTYP["S" S PSOCOMM="Supply Item",PSOOLD="Copay",PSONW="No Copay",PSOCHG=0,PSOEXMPT=1
I DRGTYP["N" S PSOCOMM="Nutritional Supplement",PSOOLD="Copay",PSONW="No Copay",PSOCHG=0,PSOEXMPT=1
K PSOTG,CHKXTYPE
I +$G(^PSRX(RXP,"IBQ")) D XTYPE1^PSOCP1
I $G(^PSRX(RXP,"IBQ"))["1" D S PSOCHG=0,PSOOLD="Copay",PSONW="No Copay",PSOEXMPT=1 Q ; COPAY EXEMPT
. N EXMT,II,PSOCIBQ
. S PSOCIBQ=$G(^PSRX(RXP,"IBQ"))
. F II=1,7,3,4,5,6,2,8 I $P(PSOCIBQ,"^",II)=1 S EXMT=$S(II=1:"SC",II=7:"CV",II=3:"AO",II=4:"IR",II=5:"EC",II=8:"SHAD",II=2:"MST",II=6:"HNC",1:"") D:EXMT'="" SETCOMM Q
D SCNEW(.PSOTG,PSOCPN,DRG,RXP)
N EXMT
I '$D(CHKXTYPE) D XTYPE
F EXMT="SC","CV","AO","IR","EC","SHAD","MST","HNC" I $D(PSOTG(EXMT)) D I 'PSOCHG Q
. I PSOTG(EXMT)=1 S PSOCHG=0 D SETCOMM
;Check copay tier. Tier zero does not have copay charges. Tier billing will be effective 2/27/17 and IB rate table decides what amount to bill based on rate effective date
N CPDATE,X D NOW^%DTC S CPDATE=X,PSOCPT=$$CPTIER^PSNAPIS("",CPDATE,DRG) K CPDATE,X
I $P(PSOCPT,"^")=0 S PSOCHG=0 Q ;Tier zero do not send to IB for copay charge
S EXMT="",MAILMSG=0 F S EXMT=$O(PSOTG(EXMT)) Q:EXMT="" I PSOTG(EXMT)="" S MAILMSG=1 Q
I MAILMSG,$D(PSOTG("SC")) I $G(PSOTG("SC"))="" S PSOCHG=2 ; 'SC' quest not answered, don't reset copay status to 'copay'
I '$G(PSOEXMPT),$P(PSOCPT,"^")=""!($P(PSOCPT,"^")>0) S PSOCOMM="Copay Tier "_$S(PSOCPT="":"Null",1:+PSOCPT),PSOOLD="No Copay",PSONW="Copay",PSODA=RXP,PREA="R",PSOCHG=1 D ACTLOG^PSOCPA Q
Q
;
SCNEW(PSOTG,PSOPT,PSODR,PSORN) ;CPRS supported ref
I '$$DT^PSOMLLDT Q
I '$G(PSOPT) Q
;I $G(PSODR),($P($G(^PSDRUG(PSODR,0)),"^",3)["S")!($P($G(^(0)),"^",3)["I") Q ;CIDC ALWAYS ASK
N PSOCIBQ,PSOQMSH,PSOQVEH,PSOQRQD,PSOQHNC,PSOQPGW,DFN,PSOSCA,ZXX
K PSOANSQ("SC>50")
S DFN=PSOPT
D SCP^PSORN52D S:PSOSCP>49&(PSOSCA) PSOANSQ("SC>50")=1
I $G(PSORN) D
. S PSOCIBQ=$G(^PSRX(PSORN,"IBQ"))
. I $TR(PSOCIBQ,"^")="" S ZXX=$G(^PSRX(PSORN,"ICD",1,0)) D ICD:ZXX'=""
I '$G(PSORN) S PSOCIBQ=""
;Rx Patient Status check is not being done here
N PSOSCMX,Y,I,J,X S (X,PSOSCMX)=""
S J=0 F S J=$O(^PS(59,J)) Q:'J I +$G(^(J,"IB")) S X=+^("IB") Q
G:'X SKIP
S X=X_"^"_PSOPT D XTYPE^IBARX
S J="" F S J=$O(Y(J)) Q:'J S I="" F S I=$O(Y(J,I)) Q:I="" S:I>0 PSOSCMX=I
SKIP ;
I $G(PSOSCA)!($G(PSOSCMX)=2) S PSOTG("SC")=$S($P(PSOCIBQ,"^")=1:1,$P(PSOCIBQ,"^")=0:0,$G(PSORN)&($P($G(^PSRX(+$G(PSORN),"IB")),"^")):0,1:"")
S:$$AO^SDCO22(PSOPT) PSOTG("AO")=$S($P(PSOCIBQ,"^",3)=1:1,$P(PSOCIBQ,"^",3)=0:0,1:"")
S:$$IR^SDCO22(PSOPT) PSOTG("IR")=$S($P(PSOCIBQ,"^",4)=1:1,$P(PSOCIBQ,"^",4)=0:0,1:"")
S:$$EC^SDCO22(PSOPT) PSOTG("EC")=$S($P(PSOCIBQ,"^",5)=1:1,$P(PSOCIBQ,"^",5)=0:0,1:"")
S:$P($$GETSTAT^DGMSTAPI(PSOPT),"^",2)="Y" PSOTG("MST")=$S($P(PSOCIBQ,"^",2)=1:1,$P(PSOCIBQ,"^",2)=0:0,1:"")
I $T(GETCUR^DGNTAPI)]"" N PSONC,PSONCX S PSONCX=$$GETCUR^DGNTAPI(PSOPT,"PSONC") I $P($G(PSONC("IND")),"^")="Y" S PSOTG("HNC")=$S($P(PSOCIBQ,"^",6)=1:1,$P(PSOCIBQ,"^",6)=0:0,1:"")
S:$P($$CVEDT^DGCV(PSOPT),"^",3) PSOTG("CV")=$S($P(PSOCIBQ,"^",7)=1:1,$P(PSOCIBQ,"^",7)=0:0,1:"")
I $L($T(GETSHAD^DGUTL3)) S:$$GETSHAD^DGUTL3(PSOPT)=1 PSOTG("SHAD")=$S($P(PSOCIBQ,"^",8)=1:1,$P(PSOCIBQ,"^",8)=0:0,1:"")
Q
;
ICD ;
D ICD^PSOCP1
Q
XTYPE ;
N PSOCIBQ,PSOSCMX,Y,I,J,X,SAVY,ZXX
S (X,PSOSCMX,SAVY)=""
S PSOCIBQ=$G(^PSRX(RXP,"IBQ")) I $TR(PSOCIBQ,"^")="" S ZXX=$G(^PSRX(RXP,"ICD",1,0)) D ICD:ZXX'=""
I $P(PSOCIBQ,"^",1)'="" S PSOTG("SC")=$P(PSOCIBQ,"^",1)
I $D(PSOTG("SC")),$P(PSOCIBQ,"^",1)="" S PSOTG("SC")="" ; USE "CURRENT" SETTING AS ANS TO SC QUEST IF IT APPLIES
S J=0 F S J=$O(^PS(59,J)) Q:'J I +$G(^(J,"IB")) S X=+^("IB") Q
I 'X Q
S X=X_"^"_PSOCPN D XTYPE^IBARX
I $G(Y)'=1 Q
S J="" F S J=$O(Y(J)) Q:'J S I="" F S SAVY=I,I=$O(Y(J,I)) Q:I="" S:I>0 PSOSCMX=I
I PSOSCMX="",SAVY=0 S PSOCHG=0,PSOEXMPT=1 S PSOCOMM="Exempt from copayment" Q ; INCOME EXEMPT OR SC
I PSOSCMX=2,'$D(PSOTG("SC")) S PSOTG("SC")=$S(($G(RXP)&($P($G(^PSRX(+$G(RXP),"IB")),"^")))!($P(PSOCIBQ,"^")=0):0,$P(PSOCIBQ,"^")=1:1,1:"") Q
Q
;
SETCOMM ;
D SETCOMM^PSOCP1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCP 10261 printed Dec 13, 2024@02:25:39 Page 2
PSOCP ;BIR/BAB - Pharmacy CO-PAY Application Utilities for IB ;02/06/92
+1 ;;7.0;OUTPATIENT PHARMACY;**20,46,71,85,137,157,143,219,239,201,225,303,460,480,485**;DEC 1997;Build 37
+2 ;
+3 ;REF/IA - IBARX/125, SDCO22/1579, PS(55/2228, PSDRUG(/221, DGMSTAPI/2716, $$GETSHAD^DGUTL3/4462
+4 ;Reference to $$CPTIER^PSNAPIS(P1,P3) supported by DBIA #2531
+5 ;Reference to $$GETSTAT^DGMSTAPI supported by DBIA 3457
+6 ;
CP ;Check if COPAY-Requires RXP,PSOSITE7
+1 IF '$DATA(PSOPAR)
DO ^PSOLSET
GOTO CP
+2 KILL PSOCP
+3 ; Set COPAY dfn PTR TO PATIENT
SET PSOCPN=$PIECE(^PSRX(RXP,0),"^",2)
+4 ; IB action type
SET PSOCP=$PIECE($GET(^PSRX(RXP,"IB")),"^")
+5 ; save current copay status
SET PSOSAVE=$SELECT(PSOCP:1,1:"")
+6 ; Set x=service^dfn^actiontype^user duz
+7 IF +$GET(PSOSITE7)'>0
SET PSOSITE7=$PIECE(^PS(59,PSOSITE,"IB"),"^")
+8 SET X=PSOSITE7_"^"_PSOCPN_"^"_PSOCP_"^"_$PIECE(^PSRX(RXP,0),"^",16)
+9 ;
RX ;Determine Orig or Refill for RX
+1 NEW PSOIB,PSOPFS,PSOCPT
SET (PSOIB,PSOREF)=0
+2 IF $GET(^PSRX(RXP,1,+$GET(YY),0))]""
SET PSOREF=YY
+3 DO PFSA^PSOPFSU1(RXP,PSOREF,2)
if +PSOPFS
GOTO PFS
+4 ; Check if bill exists
+5 IF 'PSOREF
IF +$PIECE($GET(^PSRX(RXP,"IB")),"^",2)>0
DO CHKIB^PSOCP1
IF PSOIB
GOTO QUIT
+6 ; 'POTENTIAL BILL' - ALREADY ATTEMPTED TO BILL, BUT EXCEEDED ANNUAL COPAY CAP
IF 'PSOREF
IF +$PIECE($GET(^PSRX(RXP,"IB")),"^",4)>0
GOTO QUIT
+7 IF PSOREF
IF +$GET(^PSRX(RXP,1,PSOREF,"IB"))
DO CHKIB^PSOCP1
IF PSOIB
GOTO QUIT
+8 ; POTENTIAL BILL
IF PSOREF
IF +$PIECE($GET(^PSRX(RXP,1,PSOREF,"IB")),"^",2)
GOTO QUIT
PFS ;
+1 ; set tem var to copay and check exception
SET PSOCHG=1
+2 NEW MAILMSG
+3 DO COPAYREL
+4 IF 'PSOCHG
Begin DoDot:1
+5 IF PSOSAVE
SET PSODA=RXP
SET PREA="R"
DO ACTLOG^PSOCPA
SET $PIECE(^PSRX(RXP,"IB"),"^",1)=""
End DoDot:1
if PSOPFS
DO CHRG^PSOPFSU1(RXP,PSOREF,"CG",PSOPFS)
GOTO QUIT
+6 ; IF 'SC' QUESTION APPLIES, BUT HAS NOT BEEN ANSWERED, SEND MAIL MSG AND KEEP COPAY STATUS AS IT WAS
IF PSOCHG=2
Begin DoDot:1
+7 ; SEND MAIL TO PHARMACIST, PROVIDER, AND HOLDERS OF THE PSO COPAY KEY
DO MAIL2^PSOCPE
End DoDot:1
IF 'PSOCP
if PSOPFS
DO CHRG^PSOPFSU1(RXP,PSOREF,"CG",PSOPFS)
GOTO QUIT
+8 IF PSOCHG=1
IF PSOSAVE=""
Begin DoDot:1
+9 IF '$DATA(^PSRX(RXP,"IB"))
IF 'PSOREF
SET $PIECE(^PSRX(RXP,"IB"),"^",1)=1
QUIT
+10 SET $PIECE(^PSRX(RXP,"IB"),"^",1)=1
+11 SET PSOCP=1
SET $PIECE(X,"^",3)=PSOCP
End DoDot:1
IF PSOREF
SET PSOCOMM=""
SET PSOOLD="No Copay"
SET PSONW="Copay"
SET PSODA=RXP
SET PREA="R"
DO ACTLOG^PSOCPA
+12 ; SEND MAIL TO PHARM, PROV, AND HOLDERS OF PSO COPAY KEY HOLDERS
IF PSOCHG'=2
IF $GET(MAILMSG)
DO MAIL2^PSOCPE
+13 ; Units for COPAY
+14 SET PSOCPUN=$PIECE(($PIECE(^PSRX(RXP,0),"^",8)+29)/30,".",1)
+15 ; Build softlink for x(n)=softlink^units
+16 SET X(1)="52:"_RXP
if PSOREF>0
SET X(1)=X(1)_";1:"_PSOREF
SET X(1)=X(1)_"^"_PSOCPUN
+17 ; Set correct user duz if refill
+18 IF PSOREF
if +$PIECE(^PSRX(RXP,1,PSOREF,0),"^",7)>0
SET $PIECE(X,"^",4)=$PIECE(^PSRX(RXP,1,PSOREF,0),"^",7)
+19 ;
IBNEW ; Load ^TMP global for IB call
+1 if $GET(RXP)'>0
QUIT
+2 IF PSOPFS
DO CHRG^PSOPFSU1(RXP,PSOREF,"CG",PSOPFS)
+3 if PSOPFS
GOTO QUIT
+4 NEW D0
+5 if '$DATA(X)
GOTO QUIT
+6 SET XTMP=X
SET XTMP(1)=X(1)
+7 ;
+8 ; Requires x=service^dfn^action type^user duz
+9 ; x(n)=softlink^units
+10 IF $PIECE(X,"^",3)=""
SET $PIECE(X,"^",3)=$PIECE(^PSRX(RXP,"IB"),"^",1)
+11 DO NEW^IBARX
+12 ; Returns y=1^total charges for this group or Y=-1^error code
+13 ; y(n)=IB number^charge for this Rx^AR bill #^Cap met^Partial or Full charge^Copay Exempt^Number from file 354.71
+14 ; Cap met ('1' - If patient has met cap amount or reached cap with this charge or '0' if not)
+15 ; Partial or Full ('P' for partial billing, 'F' for full billing, null for no billing)
+16 ; Copay Exempt - ('1' for exempt, '0' for non-exempt, '-1' for copay off (manila)),
+17 ; ('1' - If patient has met cap amount or reach cap with this charge
+18 ; Entry from file 354.71 will only be saved for fills that met the annual cap and could not be fully billed
+19 ;
+20 if +Y=-1
GOTO QUIT
+21 SET XTMP=XTMP_"^"_Y
SET XTMP(1)=XTMP(1)_"^"_Y(1)
+22 ;
+23 ; see if exempt or copay cap was met
+24 IF $PIECE(Y(1),"^",6)
Begin DoDot:1
+25 SET PREA="R"
SET PSOOLD="Copay"
SET PSONW="No Copay"
+26 SET PSOCOMM="RX COPAY INCOME EXEMPTION"
SET PSODA=RXP
DO ACTLOG^PSOCPA
+27 SET $PIECE(^PSRX(RXP,"IB"),"^",1)=""
End DoDot:1
GOTO QUIT
+28 IF $PIECE(Y(1),"^",4)
Begin DoDot:1
+29 SET PSOCOMM=$SELECT($PIECE(Y(1),"^",5)="F":" FULL BILLING FOR THIS FILL",$PIECE(Y(1),"^",5)="P":" PARTIAL BILLING FOR THIS FILL ",1:" NO BILLING FOR THIS FILL")
+30 SET PREA="A"
+31 SET PSODA=RXP
DO ACTLOG^PSOCPA
+32 IF $PIECE(Y(1),"^",5)'="F"
Begin DoDot:2
+33 IF PSOREF
SET $PIECE(^PSRX(RXP,1,PSOREF,"IB"),"^",2)=$PIECE(Y(1),"^",7)
QUIT
+34 SET $PIECE(^PSRX(RXP,"IB"),"^",4)=$PIECE(Y(1),"^",7)
End DoDot:2
End DoDot:1
+35 IF $PIECE(Y(1),"^",1)=""
GOTO QUIT
+36 ;
FILE ;File IB number in ^PSRX
+1 SET PSOCP2=0
+2 SET PSOCP2=+$PIECE(XTMP(1),":",3)
+3 ; Filing in refill node
if PSOCP2>0
SET ^PSRX(RXP,1,PSOCP2,"IB")=$PIECE(XTMP(1),U,3)
+4 ; If refill "IB" exists, need "IB" entry on original fill node
IF PSOCP2>0
IF '$DATA(^PSRX(RXP,"IB"))
SET ^PSRX(RXP,"IB")="1^^"
+5 ;Filing in original fill (zero node)
if PSOCP2=0
SET $PIECE(^PSRX(RXP,"IB"),"^",2)=$PIECE(XTMP(1),U,3)
QUIT ;
+1 KILL Y,PSOCP1,PSOCP2,QQ,PSOCPN,X,X2,XTMP,PSOCPUN,PSOREF,PSOCHG,PSOSAVE,PSOCOMM,PSOOLD,PSONW,PREA,PSORSN
+2 QUIT
EN DO ^PSOLSET
EN1 SET DIR(0)="NO"
SET DIR("A")="Enter PRESCRIPTION number"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EXIT
SET RXP=X
IF +$GET(^PSRX(RXP,0))'>0!+$PIECE($GET(^PSRX(RXP,"IB")),"^",0)>0
WRITE !,?10,"RE-CHECK PRESCRIPTION NUMBER AND RE-ENTER "
GOTO EN1
+1 SET PSOSITE7=$PIECE(^PS(59,PSOSITE,"IB"),"^")
+2 SET PSODFN=$PIECE(^PSRX(RXP,0),"^",2)
+3 DO CP
GOTO EN1
EXIT KILL RXP
DO FINAL^PSOLSET
QUIT
+1 ;
SC(PSODFN,PSODD) ;sup ref for CPRS, Pre-Copay enhancement
+1 NEW PSOSC
+2 IF $$DT^PSOMLLDT
SET PSOSC=""
GOTO SCQ
+3 IF $GET(PSODD)
IF ($PIECE($GET(^PSDRUG(PSODD,0)),"^",3)["S")!($PIECE($GET(^(0)),"^",3)["I")!($PIECE($GET(^(0)),"^",3)["N")
SET PSOSC=1
GOTO SCQ
+4 IF $PIECE($GET(^PS(55,+$GET(PSODFN),"PS")),"^")
IF $PIECE($GET(^PS(53,+$PIECE(^("PS"),"^"),0)),"^",7)
SET PSOSC=1
GOTO SCQ
+5 NEW I,J,X
SET (X,PSOSC)=""
+6 SET J=0
FOR
SET J=$ORDER(^PS(59,J))
if 'J
QUIT
IF +$GET(^(J,"IB"))
SET X=+^("IB")
QUIT
+7 if 'X
GOTO SCQ
+8 SET X=X_"^"_PSODFN
DO XTYPE^IBARX
+9 SET J=""
FOR
SET J=$ORDER(Y(J))
if 'J
QUIT
SET I=""
FOR
SET I=$ORDER(Y(J,I))
if I=""
QUIT
if I>0
SET PSOSC=I
SCQ QUIT $SELECT($GET(PSOSC)=2:0,1:1)
+1 ;
COPAYREL ; Recheck copay status at release
+1 ; check Rx patient status
+2 IF $PIECE(^PSRX(RXP,0),"^",3)'=""
IF $PIECE($GET(^PS(53,$PIECE(^PSRX(RXP,0),"^",3),0)),"^",7)=1
SET PSOCHG=0
SET PSOCOMM="Rx Patient Status Change"
SET PSOOLD="Copay"
SET PSONW="No Copay"
QUIT
+3 ; see if drug is nutritional supplement, investigational or supply
+4 NEW DRG,DRGTYP,X,PSOEXMPT
+5 SET DRG=+$PIECE(^PSRX(RXP,0),"^",6)
SET DRGTYP=$PIECE($GET(^PSDRUG(DRG,0)),"^",3)
+6 IF DRGTYP["I"
SET PSOCOMM="Investigational Drug"
SET PSOOLD="Copay"
SET PSONW="No Copay"
SET PSOCHG=0
SET PSOEXMPT=1
+7 IF DRGTYP["S"
SET PSOCOMM="Supply Item"
SET PSOOLD="Copay"
SET PSONW="No Copay"
SET PSOCHG=0
SET PSOEXMPT=1
+8 IF DRGTYP["N"
SET PSOCOMM="Nutritional Supplement"
SET PSOOLD="Copay"
SET PSONW="No Copay"
SET PSOCHG=0
SET PSOEXMPT=1
+9 KILL PSOTG,CHKXTYPE
+10 IF +$GET(^PSRX(RXP,"IBQ"))
DO XTYPE1^PSOCP1
+11 ; COPAY EXEMPT
IF $GET(^PSRX(RXP,"IBQ"))["1"
Begin DoDot:1
+12 NEW EXMT,II,PSOCIBQ
+13 SET PSOCIBQ=$GET(^PSRX(RXP,"IBQ"))
+14 FOR II=1,7,3,4,5,6,2,8
IF $PIECE(PSOCIBQ,"^",II)=1
SET EXMT=$SELECT(II=1:"SC",II=7:"CV",II=3:"AO",II=4:"IR",II=5:"EC",II=8:"SHAD",II=2:"MST",II=6:"HNC",1:"")
if EXMT'=""
DO SETCOMM
QUIT
End DoDot:1
SET PSOCHG=0
SET PSOOLD="Copay"
SET PSONW="No Copay"
SET PSOEXMPT=1
QUIT
+15 DO SCNEW(.PSOTG,PSOCPN,DRG,RXP)
+16 NEW EXMT
+17 IF '$DATA(CHKXTYPE)
DO XTYPE
+18 FOR EXMT="SC","CV","AO","IR","EC","SHAD","MST","HNC"
IF $DATA(PSOTG(EXMT))
Begin DoDot:1
+19 IF PSOTG(EXMT)=1
SET PSOCHG=0
DO SETCOMM
End DoDot:1
IF 'PSOCHG
QUIT
+20 ;Check copay tier. Tier zero does not have copay charges. Tier billing will be effective 2/27/17 and IB rate table decides what amount to bill based on rate effective date
+21 NEW CPDATE,X
DO NOW^%DTC
SET CPDATE=X
SET PSOCPT=$$CPTIER^PSNAPIS("",CPDATE,DRG)
KILL CPDATE,X
+22 ;Tier zero do not send to IB for copay charge
IF $PIECE(PSOCPT,"^")=0
SET PSOCHG=0
QUIT
+23 SET EXMT=""
SET MAILMSG=0
FOR
SET EXMT=$ORDER(PSOTG(EXMT))
if EXMT=""
QUIT
IF PSOTG(EXMT)=""
SET MAILMSG=1
QUIT
+24 ; 'SC' quest not answered, don't reset copay status to 'copay'
IF MAILMSG
IF $DATA(PSOTG("SC"))
IF $GET(PSOTG("SC"))=""
SET PSOCHG=2
+25 IF '$GET(PSOEXMPT)
IF $PIECE(PSOCPT,"^")=""!($PIECE(PSOCPT,"^")>0)
SET PSOCOMM="Copay Tier "_$SELECT(PSOCPT="":"Null",1:+PSOCPT)
SET PSOOLD="No Copay"
SET PSONW="Copay"
SET PSODA=RXP
SET PREA="R"
SET PSOCHG=1
DO ACTLOG^PSOCPA
QUIT
+26 QUIT
+27 ;
SCNEW(PSOTG,PSOPT,PSODR,PSORN) ;CPRS supported ref
+1 IF '$$DT^PSOMLLDT
QUIT
+2 IF '$GET(PSOPT)
QUIT
+3 ;I $G(PSODR),($P($G(^PSDRUG(PSODR,0)),"^",3)["S")!($P($G(^(0)),"^",3)["I") Q ;CIDC ALWAYS ASK
+4 NEW PSOCIBQ,PSOQMSH,PSOQVEH,PSOQRQD,PSOQHNC,PSOQPGW,DFN,PSOSCA,ZXX
+5 KILL PSOANSQ("SC>50")
+6 SET DFN=PSOPT
+7 DO SCP^PSORN52D
if PSOSCP>49&(PSOSCA)
SET PSOANSQ("SC>50")=1
+8 IF $GET(PSORN)
Begin DoDot:1
+9 SET PSOCIBQ=$GET(^PSRX(PSORN,"IBQ"))
+10 IF $TRANSLATE(PSOCIBQ,"^")=""
SET ZXX=$GET(^PSRX(PSORN,"ICD",1,0))
if ZXX'=""
DO ICD
End DoDot:1
+11 IF '$GET(PSORN)
SET PSOCIBQ=""
+12 ;Rx Patient Status check is not being done here
+13 NEW PSOSCMX,Y,I,J,X
SET (X,PSOSCMX)=""
+14 SET J=0
FOR
SET J=$ORDER(^PS(59,J))
if 'J
QUIT
IF +$GET(^(J,"IB"))
SET X=+^("IB")
QUIT
+15 if 'X
GOTO SKIP
+16 SET X=X_"^"_PSOPT
DO XTYPE^IBARX
+17 SET J=""
FOR
SET J=$ORDER(Y(J))
if 'J
QUIT
SET I=""
FOR
SET I=$ORDER(Y(J,I))
if I=""
QUIT
if I>0
SET PSOSCMX=I
SKIP ;
+1 IF $GET(PSOSCA)!($GET(PSOSCMX)=2)
SET PSOTG("SC")=$SELECT($PIECE(PSOCIBQ,"^")=1:1,$PIECE(PSOCIBQ,"^")=0:0,$GET(PSORN)&($PIECE($GET(^PSRX(+$GET(PSORN),"IB")),"^")):0,1:"")
+2 if $$AO^SDCO22(PSOPT)
SET PSOTG("AO")=$SELECT($PIECE(PSOCIBQ,"^",3)=1:1,$PIECE(PSOCIBQ,"^",3)=0:0,1:"")
+3 if $$IR^SDCO22(PSOPT)
SET PSOTG("IR")=$SELECT($PIECE(PSOCIBQ,"^",4)=1:1,$PIECE(PSOCIBQ,"^",4)=0:0,1:"")
+4 if $$EC^SDCO22(PSOPT)
SET PSOTG("EC")=$SELECT($PIECE(PSOCIBQ,"^",5)=1:1,$PIECE(PSOCIBQ,"^",5)=0:0,1:"")
+5 if $PIECE($$GETSTAT^DGMSTAPI(PSOPT),"^",2)="Y"
SET PSOTG("MST")=$SELECT($PIECE(PSOCIBQ,"^",2)=1:1,$PIECE(PSOCIBQ,"^",2)=0:0,1:"")
+6 IF $TEXT(GETCUR^DGNTAPI)]""
NEW PSONC,PSONCX
SET PSONCX=$$GETCUR^DGNTAPI(PSOPT,"PSONC")
IF $PIECE($GET(PSONC("IND")),"^")="Y"
SET PSOTG("HNC")=$SELECT($PIECE(PSOCIBQ,"^",6)=1:1,$PIECE(PSOCIBQ,"^",6)=0:0,1:"")
+7 if $PIECE($$CVEDT^DGCV(PSOPT),"^",3)
SET PSOTG("CV")=$SELECT($PIECE(PSOCIBQ,"^",7)=1:1,$PIECE(PSOCIBQ,"^",7)=0:0,1:"")
+8 IF $LENGTH($TEXT(GETSHAD^DGUTL3))
if $$GETSHAD^DGUTL3(PSOPT)=1
SET PSOTG("SHAD")=$SELECT($PIECE(PSOCIBQ,"^",8)=1:1,$PIECE(PSOCIBQ,"^",8)=0:0,1:"")
+9 QUIT
+10 ;
ICD ;
+1 DO ICD^PSOCP1
+2 QUIT
XTYPE ;
+1 NEW PSOCIBQ,PSOSCMX,Y,I,J,X,SAVY,ZXX
+2 SET (X,PSOSCMX,SAVY)=""
+3 SET PSOCIBQ=$GET(^PSRX(RXP,"IBQ"))
IF $TRANSLATE(PSOCIBQ,"^")=""
SET ZXX=$GET(^PSRX(RXP,"ICD",1,0))
if ZXX'=""
DO ICD
+4 IF $PIECE(PSOCIBQ,"^",1)'=""
SET PSOTG("SC")=$PIECE(PSOCIBQ,"^",1)
+5 ; USE "CURRENT" SETTING AS ANS TO SC QUEST IF IT APPLIES
IF $DATA(PSOTG("SC"))
IF $PIECE(PSOCIBQ,"^",1)=""
SET PSOTG("SC")=""
+6 SET J=0
FOR
SET J=$ORDER(^PS(59,J))
if 'J
QUIT
IF +$GET(^(J,"IB"))
SET X=+^("IB")
QUIT
+7 IF 'X
QUIT
+8 SET X=X_"^"_PSOCPN
DO XTYPE^IBARX
+9 IF $GET(Y)'=1
QUIT
+10 SET J=""
FOR
SET J=$ORDER(Y(J))
if 'J
QUIT
SET I=""
FOR
SET SAVY=I
SET I=$ORDER(Y(J,I))
if I=""
QUIT
if I>0
SET PSOSCMX=I
+11 ; INCOME EXEMPT OR SC
IF PSOSCMX=""
IF SAVY=0
SET PSOCHG=0
SET PSOEXMPT=1
SET PSOCOMM="Exempt from copayment"
QUIT
+12 IF PSOSCMX=2
IF '$DATA(PSOTG("SC"))
SET PSOTG("SC")=$SELECT(($GET(RXP)&($PIECE($GET(^PSRX(+$GET(RXP),"IB")),"^")))!($PIECE(PSOCIBQ,"^")=0):0,$PIECE(PSOCIBQ,"^")=1:1,1:"")
QUIT
+13 QUIT
+14 ;
SETCOMM ;
+1 DO SETCOMM^PSOCP1
+2 QUIT
+3 ;
