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

PRCAXP.m

Go to the documentation of this file.
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
 ;
 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