PRCAXP ;WASH-ISC@ALTOONA,PA/TJK-PRINT RX-COPAY EXEMPTION REPORT ;10/23/93 10:01 AM
V ;;4.5;Accounts Receivable;**315**;Mar 20, 1995;Build 67
;;Per VA Directive 6402, this routine should not be modified.
NEW BEG,END,%DT,%ZIS,IOP,POP,Y,%
BEG W ! D NOW^%DTC S %DT(0)=-%,%DT="AEXP",%DT("A")="Start Date: " D ^%DT G:Y<0 Q S BEG=Y
S %DT="AEX",%DT("A")=" End Date: ",%DT("B")="T" D ^%DT G:Y<0 Q S END=Y
W !!,"You will need a 132 column printer for this report!",!
W ! K IO("Q") S %ZIS="MQ" D ^%ZIS G:POP Q
I $D(IO("Q")) S ZTRTN="DQ^PRCAXP",ZTSAVE("BEG")="",ZTSAVE("END")="" D ^%ZTLOAD G Q
U IO
DQ ;ENTRY POINT FROM TASK MANAGER FOR PRINTING REPORT
NEW Y,TODAY,PG,I,PRCA,PRCAHDR,BEGPR,ENDPR,TRDATE,TRNO,T0,T1,BILL,TRAMT,OUT,PTNM,DFN,CONTINUE
NEW ID,REC,TTYPE,VA,PTOT,PGTOT,TOT,LAST,BLNO,EFDT,DTH
COMPUTE ;SETS TEMPORARY GLOBAL FOR PRINTING
K ^TMP($J) S TRDATE=BEG-1,(TOT("D"),TOT("E"),TOT("I"))=0,U="^"
F S TRDATE=$O(^PRCA(433,"ACE",TRDATE)) G PRINT:'TRDATE!($P(TRDATE,".")>END) S TRNO=0 D
.F S TRNO=$O(^PRCA(433,"ACE",TRDATE,TRNO)) Q:'TRNO D
..S T0=$G(^PRCA(433,TRNO,0)),T1=$G(^(1)) Q:T0=""
..S BLNO=$P(T0,U,2),TRAMT=$P(T1,U,5),TTYPE=$S($P(T1,U,2)=35:"D",$P(T1,U,2)=1:"I",1:"E"),EFDT=$P(T1,U,1) ;*315 START
..;S DFN=$P(^PRCA(430,BLNO,0),U,9),BILL=$P(^(0),U)
..S P0=$G(^PRCA(430,BLNO,0)),DFN=$P(P0,U,9),BILL=$P(P0,U),IBN=0
..S DFN=$P(^RCD(340,+DFN,0),U) Q:'DFN!(DFN'["DPT(") S DFN=+DFN
..D DEM^VADPT S PTNM=VADM(1),ID=$E(PTNM,1)_VA("BID") S DTH=$S(+VADM(6):"*",1:"") D KVAR^VADPT
..D FNDBIL(TRNO,TTYPE)
PRINT ;PRINT REPORT
S LAST=""
S Y=BEG X ^DD("DD") S BEGPR=Y
S Y=END X ^DD("DD") S ENDPR=Y
S Y=DT X ^DD("DD") S TODAY=Y,PG=0 D HEAD
I '$D(^TMP($J)) W !!,"NO EXEMPTIONS FOR THIS TIME PERIOD" G Q
S PTNM="" F S PTNM=$O(^TMP($J,PTNM)) Q:PTNM=""!($D(OUT)) D
.S DFN=0 F S DFN=$O(^TMP($J,PTNM,DFN)) Q:'DFN!($D(OUT)) S CONTINUE="",PTOT=0 D I PTOT W !,?115,"-------------",!,?115,$J(+PTOT,13,2),!
..S BILL="" F S BILL=$O(^TMP($J,PTNM,DFN,BILL)) Q:BILL=""!($D(OUT)) D
...S TRNO=0 F S TRNO=$O(^TMP($J,PTNM,DFN,BILL,TRNO)) Q:TRNO=""!($D(OUT)) D ;*315 START
....S CONTINUE=""
....S RX=0 F S RX=$O(^TMP($J,PTNM,DFN,BILL,TRNO,RX)) Q:'RX!($D(OUT)) D
.....S REC=^TMP($J,PTNM,DFN,BILL,TRNO,RX),TRAMT=$P(REC,U,1) W ! W:$D(CONTINUE) $P(REC,"^",4),$E(PTNM,1,25)," ",?28,$P(REC,U,2),?35,BILL,?48,TRNO,?56,$P(REC,U,3)
.....W ?60,$S(RX=1:"",1:$P(REC,U,5)) W ?70,$E($P(REC,U,6),1,17),?90,$P(REC,U,7),?100,$P(REC,U,8) I $D(CONTINUE),TRNO'=LAST W ?115,$J(TRAMT,13,2)
.....I $D(CONTINUE),TRNO'=LAST S PTOT=PTOT+TRAMT,PGTOT=+$G(PGTOT)+TRAMT,TOT($S($P(REC,U,3)]"":$P(REC,U,3),1:"UNK"))=$G(TOT($S($P(REC,U,3)]"":$P(REC,U,3),1:"UNK")))+REC ;*315 END
.....K CONTINUE S LAST=TRNO D HEAD:($Y+4)>IOSL
G:$D(OUT) Q
W !,"* -indicates patient is deceased"
D HEAD:($Y+7)>IOSL
W !!,"EXEMPTION TYPES AND TOTALS"
W !!,"D=DECREASE ADJUSTMENT ",?35,$J(TOT("D"),13,2),!,"E=INTEREST/ADMIN EXEMPTION ",?35,$J(TOT("E"),13,2),!,"I=INCREASE ADJUSTMENT FOR REFUND ",?35,$J(TOT("I"),13,2)
I $D(TOT("UNK")) W !,"UNK=EXEMPTION TYPE UNKNOWN",?35,$J(TOT("UNK"),13,2)
W !,?35,"-------------",!,?35,$J(PGTOT,13,2)
K BEG,END,IO("Q") ;K ^TMP($J)
Q D ^%ZISC Q
;
FNDBIL(TRNO,TTYPE) ;
N FOUND,CNT,IBN,IB0,RR,RX,DRUG,FLDT,EDT,EFFDT,IBAMT,IBAS,ARTRN
S (IBN,FOUND,CNT,RX)=0,EDT=""
F S IBN=$O(^IB("ABIL",BILL,IBN)) Q:IBN="" D
.S IB0=^IB(IBN,0),RR=$P(IB0,U,4),EDT=$P(IB0,U,17),IBAMT=$P(IB0,U,7),ARTRN=$P(IB0,U,12)
.I EDT="" S EDT=EFDT
.I EDT="" S EDT=TRDATE
.I ARTRN=TRNO S FOUND=1 D DATA Q
.I 'FOUND,ARTRN="" D DATA
I CNT=0,RX=0 D
.I EDT="" S EDT=EFDT
.I EDT="" S EDT=TRDATE
.S EFFDT=$$FMTE^XLFDT(EDT,"2DZ")
.D SET(1)
Q
;
DATA ; SET UP DATA
N RIEN,RFL
S CNT=CNT+1
S RIEN=+$P(RR,"52:",2),RFL=+$P(RR,":",3)
S DRUG=$P($$GET1^PSODI(52,RIEN,6,"E"),U,2)
S RX=$P($$GET1^PSODI(52,RIEN,.01,"E"),U,2)
I RFL>0 S FLDT=$P($$GET1^PSODI(52.1,RFL_","_RIEN,.01,"I"),U,2)
I RFL=0 S FLDT=$P($$GET1^PSODI(52,RIEN,22,"I"),U,2)
S EFFDT=$$FMTE^XLFDT(EDT,"2DZ"),FLDT=$$FMTE^XLFDT(FLDT,"2DZ")
I $D(^TMP($J,PTNM,DFN,BILL,TRNO,RX)) Q
D SET(RX)
Q
;
SET(RX) ;
S ^TMP($J,PTNM,DFN,BILL,TRNO,RX)=TRAMT_U_ID_U_TTYPE_U_DTH_U_$G(RX)_U_$G(DRUG)_U_$G(FLDT)_U_$G(EFFDT)_U_$G(ARTRN)_U_$G(IBAS)_U_$G(IBN) ;*315 END
Q
;
HEAD ;PRINTS HEADING
I PG,$E(IOST,1,2)["C-" D SCR Q:$D(OUT)
W @IOF S PG=PG+1
W !!,"Pg. "_PG,?130-$L(TODAY),TODAY
S PRCAHDR="MEDICATION CO-PAY EXEMPTION REPORT",PRCA="",$P(PRCA,"*",(130-$L(PRCAHDR))\2)="*",PRCAHDR=PRCA_" "_PRCAHDR_" "_PRCA
W !,PRCAHDR,!,?53,BEGPR,"-",ENDPR
W !,?35,"BILL",?48,"TRAN.",?56,"EXP",?90,"FILL/",?100,"EFFECTIVE" ;*315 START
W !,"PATIENT",?28,"ID",?35,"NUMBER",?48,"NUMBER",?56,"TYP",?60,"RX",?70,"DRUG NAME",?90,"REFL DT",?102,"DATE",?120,"AMOUNT" ;*315 END
S PRCA="",$P(PRCA,"-",132)="" W !,PRCA
S CONTINUE=""
Q
;
SCR ;
Q:$E(IOST,1,2)'["C-"
N DIR,YY,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
F YY=$Y:1:(IOSL-2) W !
S DIR(0)="E" D ^DIR I $D(DIRUT)!($D(DTOUT)) S OUT=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAXP 5008 printed Sep 23, 2025@19:18:12 Page 2
PRCAXP ;WASH-ISC@ALTOONA,PA/TJK-PRINT RX-COPAY EXEMPTION REPORT ;10/23/93 10:01 AM
V ;;4.5;Accounts Receivable;**315**;Mar 20, 1995;Build 67
+1 ;;Per VA Directive 6402, this routine should not be modified.
+2 NEW BEG,END,%DT,%ZIS,IOP,POP,Y,%
BEG WRITE !
DO NOW^%DTC
SET %DT(0)=-%
SET %DT="AEXP"
SET %DT("A")="Start Date: "
DO ^%DT
if Y<0
GOTO Q
SET BEG=Y
+1 SET %DT="AEX"
SET %DT("A")=" End Date: "
SET %DT("B")="T"
DO ^%DT
if Y<0
GOTO Q
SET END=Y
+2 WRITE !!,"You will need a 132 column printer for this report!",!
+3 WRITE !
KILL IO("Q")
SET %ZIS="MQ"
DO ^%ZIS
if POP
GOTO Q
+4 IF $DATA(IO("Q"))
SET ZTRTN="DQ^PRCAXP"
SET ZTSAVE("BEG")=""
SET ZTSAVE("END")=""
DO ^%ZTLOAD
GOTO Q
+5 USE IO
DQ ;ENTRY POINT FROM TASK MANAGER FOR PRINTING REPORT
+1 NEW Y,TODAY,PG,I,PRCA,PRCAHDR,BEGPR,ENDPR,TRDATE,TRNO,T0,T1,BILL,TRAMT,OUT,PTNM,DFN,CONTINUE
+2 NEW ID,REC,TTYPE,VA,PTOT,PGTOT,TOT,LAST,BLNO,EFDT,DTH
COMPUTE ;SETS TEMPORARY GLOBAL FOR PRINTING
+1 KILL ^TMP($JOB)
SET TRDATE=BEG-1
SET (TOT("D"),TOT("E"),TOT("I"))=0
SET U="^"
+2 FOR
SET TRDATE=$ORDER(^PRCA(433,"ACE",TRDATE))
if 'TRDATE!($PIECE(TRDATE,".")>END)
GOTO PRINT
SET TRNO=0
Begin DoDot:1
+3 FOR
SET TRNO=$ORDER(^PRCA(433,"ACE",TRDATE,TRNO))
if 'TRNO
QUIT
Begin DoDot:2
+4 SET T0=$GET(^PRCA(433,TRNO,0))
SET T1=$GET(^(1))
if T0=""
QUIT
+5 ;*315 START
SET BLNO=$PIECE(T0,U,2)
SET TRAMT=$PIECE(T1,U,5)
SET TTYPE=$SELECT($PIECE(T1,U,2)=35:"D",$PIECE(T1,U,2)=1:"I",1:"E")
SET EFDT=$PIECE(T1,U,1)
+6 ;S DFN=$P(^PRCA(430,BLNO,0),U,9),BILL=$P(^(0),U)
+7 SET P0=$GET(^PRCA(430,BLNO,0))
SET DFN=$PIECE(P0,U,9)
SET BILL=$PIECE(P0,U)
SET IBN=0
+8 SET DFN=$PIECE(^RCD(340,+DFN,0),U)
if 'DFN!(DFN'["DPT(")
QUIT
SET DFN=+DFN
+9 DO DEM^VADPT
SET PTNM=VADM(1)
SET ID=$EXTRACT(PTNM,1)_VA("BID")
SET DTH=$SELECT(+VADM(6):"*",1:"")
DO KVAR^VADPT
+10 DO FNDBIL(TRNO,TTYPE)
End DoDot:2
End DoDot:1
PRINT ;PRINT REPORT
+1 SET LAST=""
+2 SET Y=BEG
XECUTE ^DD("DD")
SET BEGPR=Y
+3 SET Y=END
XECUTE ^DD("DD")
SET ENDPR=Y
+4 SET Y=DT
XECUTE ^DD("DD")
SET TODAY=Y
SET PG=0
DO HEAD
+5 IF '$DATA(^TMP($JOB))
WRITE !!,"NO EXEMPTIONS FOR THIS TIME PERIOD"
GOTO Q
+6 SET PTNM=""
FOR
SET PTNM=$ORDER(^TMP($JOB,PTNM))
if PTNM=""!($DATA(OUT))
QUIT
Begin DoDot:1
+7 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,PTNM,DFN))
if 'DFN!($DATA(OUT))
QUIT
SET CONTINUE=""
SET PTOT=0
Begin DoDot:2
+8 SET BILL=""
FOR
SET BILL=$ORDER(^TMP($JOB,PTNM,DFN,BILL))
if BILL=""!($DATA(OUT))
QUIT
Begin DoDot:3
+9 ;*315 START
SET TRNO=0
FOR
SET TRNO=$ORDER(^TMP($JOB,PTNM,DFN,BILL,TRNO))
if TRNO=""!($DATA(OUT))
QUIT
Begin DoDot:4
+10 SET CONTINUE=""
+11 SET RX=0
FOR
SET RX=$ORDER(^TMP($JOB,PTNM,DFN,BILL,TRNO,RX))
if 'RX!($DATA(OUT))
QUIT
Begin DoDot:5
+12 SET REC=^TMP($JOB,PTNM,DFN,BILL,TRNO,RX)
SET TRAMT=$PIECE(REC,U,1)
WRITE !
if $DATA(CONTINUE)
WRITE $PIECE(REC,"^",4),$EXTRACT(PTNM,1,25)," ",?28,$PIECE(REC,U,2),?35,BILL,?48,TRNO,?56,$PIECE(REC,U,3)
+13 WRITE ?60,$SELECT(RX=1:"",1:$PIECE(REC,U,5))
WRITE ?70,$EXTRACT($PIECE(REC,U,6),1,17),?90,$PIECE(REC,U,7),?100,$PIECE(REC,U,8)
IF $DATA(CONTINUE)
IF TRNO'=LAST
WRITE ?115,$JUSTIFY(TRAMT,13,2)
+14 ;*315 END
IF $DATA(CONTINUE)
IF TRNO'=LAST
SET PTOT=PTOT+TRAMT
SET PGTOT=+$GET(PGTOT)+TRAMT
SET TOT($SELECT($PIECE(REC,U,3)]"":$PIECE(REC,U,3),1:"UNK"))=$GET(TOT($SELECT($PIECE(REC,U,3)]"":$PIECE(REC,U,3),1:"UNK")))+REC
+15 KILL CONTINUE
SET LAST=TRNO
if ($Y+4)>IOSL
DO HEAD
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
IF PTOT
WRITE !,?115,"-------------",!,?115,$JUSTIFY(+PTOT,13,2),!
End DoDot:1
+16 if $DATA(OUT)
GOTO Q
+17 WRITE !,"* -indicates patient is deceased"
+18 if ($Y+7)>IOSL
DO HEAD
+19 WRITE !!,"EXEMPTION TYPES AND TOTALS"
+20 WRITE !!,"D=DECREASE ADJUSTMENT ",?35,$JUSTIFY(TOT("D"),13,2),!,"E=INTEREST/ADMIN EXEMPTION ",?35,$JUSTIFY(TOT("E"),13,2),!,"I=INCREASE ADJUSTMENT FOR REFUND ",?35,$JUSTIFY(TOT("I"),13,2)
+21 IF $DATA(TOT("UNK"))
WRITE !,"UNK=EXEMPTION TYPE UNKNOWN",?35,$JUSTIFY(TOT("UNK"),13,2)
+22 WRITE !,?35,"-------------",!,?35,$JUSTIFY(PGTOT,13,2)
+23 ;K ^TMP($J)
KILL BEG,END,IO("Q")
Q DO ^%ZISC
QUIT
+1 ;
FNDBIL(TRNO,TTYPE) ;
+1 NEW FOUND,CNT,IBN,IB0,RR,RX,DRUG,FLDT,EDT,EFFDT,IBAMT,IBAS,ARTRN
+2 SET (IBN,FOUND,CNT,RX)=0
SET EDT=""
+3 FOR
SET IBN=$ORDER(^IB("ABIL",BILL,IBN))
if IBN=""
QUIT
Begin DoDot:1
+4 SET IB0=^IB(IBN,0)
SET RR=$PIECE(IB0,U,4)
SET EDT=$PIECE(IB0,U,17)
SET IBAMT=$PIECE(IB0,U,7)
SET ARTRN=$PIECE(IB0,U,12)
+5 IF EDT=""
SET EDT=EFDT
+6 IF EDT=""
SET EDT=TRDATE
+7 IF ARTRN=TRNO
SET FOUND=1
DO DATA
QUIT
+8 IF 'FOUND
IF ARTRN=""
DO DATA
End DoDot:1
+9 IF CNT=0
IF RX=0
Begin DoDot:1
+10 IF EDT=""
SET EDT=EFDT
+11 IF EDT=""
SET EDT=TRDATE
+12 SET EFFDT=$$FMTE^XLFDT(EDT,"2DZ")
+13 DO SET(1)
End DoDot:1
+14 QUIT
+15 ;
DATA ; SET UP DATA
+1 NEW RIEN,RFL
+2 SET CNT=CNT+1
+3 SET RIEN=+$PIECE(RR,"52:",2)
SET RFL=+$PIECE(RR,":",3)
+4 SET DRUG=$PIECE($$GET1^PSODI(52,RIEN,6,"E"),U,2)
+5 SET RX=$PIECE($$GET1^PSODI(52,RIEN,.01,"E"),U,2)
+6 IF RFL>0
SET FLDT=$PIECE($$GET1^PSODI(52.1,RFL_","_RIEN,.01,"I"),U,2)
+7 IF RFL=0
SET FLDT=$PIECE($$GET1^PSODI(52,RIEN,22,"I"),U,2)
+8 SET EFFDT=$$FMTE^XLFDT(EDT,"2DZ")
SET FLDT=$$FMTE^XLFDT(FLDT,"2DZ")
+9 IF $DATA(^TMP($JOB,PTNM,DFN,BILL,TRNO,RX))
QUIT
+10 DO SET(RX)
+11 QUIT
+12 ;
SET(RX) ;
+1 ;*315 END
SET ^TMP($JOB,PTNM,DFN,BILL,TRNO,RX)=TRAMT_U_ID_U_TTYPE_U_DTH_U_$GET(RX)_U_$GET(DRUG)_U_$GET(FLDT)_U_$GET(EFFDT)_U_$GET(ARTRN)_U_$GET(IBAS)_U_$GET(IBN)
+2 QUIT
+3 ;
HEAD ;PRINTS HEADING
+1 IF PG
IF $EXTRACT(IOST,1,2)["C-"
DO SCR
if $DATA(OUT)
QUIT
+2 WRITE @IOF
SET PG=PG+1
+3 WRITE !!,"Pg. "_PG,?130-$LENGTH(TODAY),TODAY
+4 SET PRCAHDR="MEDICATION CO-PAY EXEMPTION REPORT"
SET PRCA=""
SET $PIECE(PRCA,"*",(130-$LENGTH(PRCAHDR))\2)="*"
SET PRCAHDR=PRCA_" "_PRCAHDR_" "_PRCA
+5 WRITE !,PRCAHDR,!,?53,BEGPR,"-",ENDPR
+6 ;*315 START
WRITE !,?35,"BILL",?48,"TRAN.",?56,"EXP",?90,"FILL/",?100,"EFFECTIVE"
+7 ;*315 END
WRITE !,"PATIENT",?28,"ID",?35,"NUMBER",?48,"NUMBER",?56,"TYP",?60,"RX",?70,"DRUG NAME",?90,"REFL DT",?102,"DATE",?120,"AMOUNT"
+8 SET PRCA=""
SET $PIECE(PRCA,"-",132)=""
WRITE !,PRCA
+9 SET CONTINUE=""
+10 QUIT
+11 ;
SCR ;
+1 if $EXTRACT(IOST,1,2)'["C-"
QUIT
+2 NEW DIR,YY,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
+3 FOR YY=$Y:1:(IOSL-2)
WRITE !
+4 SET DIR(0)="E"
DO ^DIR
IF $DATA(DIRUT)!($DATA(DTOUT))
SET OUT=1
+5 QUIT
