- 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 Feb 18, 2025@23:08:34 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
