PSOCP.m

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 ---PSOCP   10261     printed  Feb 18, 2025@23:52:06                                                                                                                                                                                                      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