PRCAHIS ;WASH-ISC@ALTOONA,PA/LDB - Transaction History Report ;9/27/93 4:32 PM
V ;;4.5;Accounts Receivable;**110,198,233,315,340,377,381,389**;Mar 20, 1995;Build 36
;;Per VA Directive 6402, this routine should not be modified.
;
EN ;Ask debtor and date range for transaction history
K DIR S POP=0
N DPTNOFZY,DPTNOFZK S (DPTNOFZY,DPTNOFZK)=1
S DIR(0)="PO^340:QEAMZ",DIR("A")="Select Patient ",DIR("?")="Enter a Patient name" D ^DIR
I $D(DIRUT)!(Y="") G EXIT1
I $P($G(^RCD(340,+Y,0)),U)'["DPT" W *7 G EN
S DEB=+Y K DIR
I '$D(^PRCA(433,"ATD",DEB)),'$D(^PRCA(430,"ATD",DEB)),'$D(^RC(341,"AD",DEB)) W !,"This patient has no activity." Q ;PRCA*4.5*389
S BDATE=$O(^PRCA(433,"ATD",+DEB,0)),DIR(0)="DO" S:'BDATE BDATE=2910101
S DIR("A")="History beginning",DIR("B")=$$FMTE^XLFDT(BDATE,"1D")
S DIR("?")="The default date is either the last statement day or T-30, but any date may be entered."
D ^DIR
S:Y'="" BDATE=Y I $D(DIRUT)&'Y G EXIT1 Q
K DIR,X,Y
S DIR(0)="DO^"_BDATE_":DT"
S DIR("A")="History ending",DIR("B")=$$FMTE^XLFDT(DT,"1D")
D ^DIR S:Y="" Y=DT I $D(DIRUT)&'Y G EXIT1 Q
S EDATE=Y
K DIR
TYPE S DIC="^PRCA(430.3,",DIC(0)="QEMZ",DIC("S")="I +Y,(+Y<15!(""^24^25^29^34^35^40^41^43^45^47^51^53^54^55^56^57^60^64^65^66^67^68^70^71^72^73^74^75^76^79^80^83^84^85^86^87^88^89^90^91^92^""[(""^""_+Y_""^"")))" ; PRCA*4.5*377/381
S Y=0 R !,"TRANSACTION TYPE: ALL//",X:DTIME I '$T!(X="^") Q
I X]"",X'="ALL" D ^DIC
I X["?" W !!,"Enter 'ALL' for all types of transactions in the AR TRANSACTION TYPE FILE",!,"including COMMENTS and STATEMENT DATES.",! G TYPE
G:Y<0 EXIT1 S TYP=$S(+Y:+Y,1:X)
I $P($G(^PRCA(430.3,+Y,0)),"^",3)>100 W !!,"This is STATUS. Enter a transaction type only." G TYPE
S %ZIS="AEQ" D ^%ZIS G:POP EXIT1
I $D(IO("Q")) D Q
.S ZTSAVE("DEB")="",ZTSAVE("BDATE")="",ZTSAVE("EDATE")="",ZTSAVE("TYP")="",ZTRTN="DQ^PRCAHIS",ZTDESC="Patient Transaction History Report"
.D ^%ZTLOAD,^%ZISC,EXIT1 K ZTSAVE,ZTRTN Q
;
DQ ;Call to build array of payment transactions
;
U IO
D TRANS^PRCAHIS1
I '$D(^TMP("PRCAGT",$J)) W !!,"This patient has no activity during this time period."
I $D(^TMP("PRCAGT",$J)) D HDR,PRINT
;
EXIT1 K AMT,BDATE,BN,BN0,CAT,CATCARE,EDATE,EVNTT,DAT1,DAT2,DATE,DEB,DIC,DIR,DIWL,DIWF,DIWR,DIWT,DUOUT,DX,DY,EVNT,EVNTT,LINE,PG,PNODE,TBAL,TOTPRIN,TOTTRAN,TTYP,TYP,TN,TN0,X,Y,Z,ZTSK,^TMP("PRCAGT",$J),^UTILITY($J)
I $D(DIRUT)!POP K DIRUT,POP Q
;end of routine
EXIT2 I $E(IOST,1,2)'="C-" W @IOF D ^%ZISC Q
I $E(IOST,1,2)="C-" W ! D ENS^%ZISS S DY=IOM-1,DX=0 X IOXY D KILL^%ZISS K DIR,X,Y,^UTILITY($J) S DIR(0)="E" D ^DIR
I $D(DIRUT) K DIRUT Q
D ^%ZISC
G EN
;
;
PRINT ;Print transactions
K DIRUT
S DATE=0 F S DATE=$O(^TMP("PRCAGT",$J,DEB,DATE)) Q:'DATE Q:$D(DIRUT) D
.S BN="" F S BN=$O(^TMP("PRCAGT",$J,DEB,DATE,BN)) Q:BN=""!($D(DIRUT)) D SCRN D
..I $D(^TMP("PRCAGT",$J,DEB,DATE,0)) S (BN0,PNODE)=^(0) D
...W !,$$FMTE^XLFDT($P(DATE,".")),?16
...S TYP=$P(BN0,"^",2) W $S(TYP=1:"COMMENT",1:"PATIENT STATEMENT PRINTED") I TYP=1 S EVNT=$P(BN0,"^",3) D
....W:$D(^RC(341,+EVNT,4)) !,?16,$P(^(4),"^")
....I $O(^RC(341,+EVNT,2,0)) S EVNTT=0 F S EVNTT=$O(^RC(341,+EVNT,2,EVNTT)) Q:'EVNTT I $D(^(EVNTT,0)) S X=^(0) D Q:$D(DIRUT) D ^DIWW
.....S DIWL=17,DIWF="WC63" D ^DIWP
.....D SCRN
..Q:(BN=0) S TN="" F S TN=$O(^TMP("PRCAGT",$J,DEB,DATE,BN,TN)) Q:TN="" Q:$D(DIRUT) D SCRN D
...I 'TN,$D(^TMP("PRCAGT",$J,DEB,DATE,BN,0)) S PNODE=^(0),BN0=$G(^PRCA(430,+BN,0)) W !!,$$FMTE^XLFDT($P(DATE,".")) D
....S CAT=$P(BN0,"^",2),CAT=$S(CAT=24&$P(BN0,"^",16):$P(^PRCA(430.2,$P(BN0,"^",16),0),"^"),1:$P($G(^PRCA(430.2,+CAT,0)),"^"))
....W ?16,CAT," BILL",?56,$P($G(^PRCA(430,+BN,0)),"^"),?69,$J(+PNODE,10,2)
....W !,?16,$P($G(^PRCA(430.3,+$P(BN0,"^",8),0)),"^")
...I TN S PNODE=^TMP("PRCAGT",$J,DEB,DATE,BN,TN) W !!,$$FMTE^XLFDT(DATE,"1D"),?16 S TYP=$P($G(^PRCA(433,+TN,1)),"^",2),TTYP=$P($G(^PRCA(430.3,+TYP,0)),U) W TTYP D
....S CAT=$P($G(^PRCA(430,+BN,0)),"^",2),CAT=$P($G(^PRCA(430.2,+CAT,0)),"^")
....S CATCARE=$P($G(^PRCA(430,+BN,0)),"^",16),CATCARE=$P($G(^PRCA(430.2,+$P(^(0),"^",16),0)),"^")
...I TN W ?56,$P($G(^PRCA(430,+BN,0)),"^") W:+TYP'=45 ?69,$J(+PNODE,10,2)
...I TN W !?16,CAT W:CATCARE]"" !,?16,CATCARE
...I TN,(+TYP=45) D
....I $D(^PRCA(433,+TN,5)) W !?16,$P(^(5),"^",2)
....I $O(^PRCA(433,+TN,7,0)) S TN0=0 F S TN0=$O(^PRCA(433,+TN,7,TN0)) Q:'TN0 I $D(^(TN0,0)) S X=^(0) D Q:$D(DIRUT) D ^DIWW
.....S DIWL=17,DIWF="C63W" D ^DIWP
...D SCRN
..Q
.Q
Q
;
SCRN ;Check for screen
N X,Y K DIR I ($Y+5)>IOSL D
.I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR Q:$D(DIRUT)
.D HDR
Q
;
HDR ;Heading for report
S PG=PG+1
W @IOF,!,?20,"Patient Transaction History Report",?70,"Page ",PG
W !,?20,"-------------------------------------"
W !!,?18,"For Patient: ",$$NAM^RCFN01(DEB),!,?25,"SSN : ",$$SSN^RCFN01(DEB)
W !,?20,"For dates: ",$$FMTE^XLFDT(BDATE,"1D"),"-",$$FMTE^XLFDT(EDATE,"1D")
W !!," DATE",?16,"ACTIVITY",?56,"BILL #",?73,"AMOUNT",!,LINE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAHIS 5018 printed Dec 13, 2024@01:39:49 Page 2
PRCAHIS ;WASH-ISC@ALTOONA,PA/LDB - Transaction History Report ;9/27/93 4:32 PM
V ;;4.5;Accounts Receivable;**110,198,233,315,340,377,381,389**;Mar 20, 1995;Build 36
+1 ;;Per VA Directive 6402, this routine should not be modified.
+2 ;
EN ;Ask debtor and date range for transaction history
+1 KILL DIR
SET POP=0
+2 NEW DPTNOFZY,DPTNOFZK
SET (DPTNOFZY,DPTNOFZK)=1
+3 SET DIR(0)="PO^340:QEAMZ"
SET DIR("A")="Select Patient "
SET DIR("?")="Enter a Patient name"
DO ^DIR
+4 IF $DATA(DIRUT)!(Y="")
GOTO EXIT1
+5 IF $PIECE($GET(^RCD(340,+Y,0)),U)'["DPT"
WRITE *7
GOTO EN
+6 SET DEB=+Y
KILL DIR
+7 ;PRCA*4.5*389
IF '$DATA(^PRCA(433,"ATD",DEB))
IF '$DATA(^PRCA(430,"ATD",DEB))
IF '$DATA(^RC(341,"AD",DEB))
WRITE !,"This patient has no activity."
QUIT
+8 SET BDATE=$ORDER(^PRCA(433,"ATD",+DEB,0))
SET DIR(0)="DO"
if 'BDATE
SET BDATE=2910101
+9 SET DIR("A")="History beginning"
SET DIR("B")=$$FMTE^XLFDT(BDATE,"1D")
+10 SET DIR("?")="The default date is either the last statement day or T-30, but any date may be entered."
+11 DO ^DIR
+12 if Y'=""
SET BDATE=Y
IF $DATA(DIRUT)&'Y
GOTO EXIT1
QUIT
+13 KILL DIR,X,Y
+14 SET DIR(0)="DO^"_BDATE_":DT"
+15 SET DIR("A")="History ending"
SET DIR("B")=$$FMTE^XLFDT(DT,"1D")
+16 DO ^DIR
if Y=""
SET Y=DT
IF $DATA(DIRUT)&'Y
GOTO EXIT1
QUIT
+17 SET EDATE=Y
+18 KILL DIR
TYPE ; PRCA*4.5*377/381
SET DIC="^PRCA(430.3,"
SET DIC(0)="QEMZ"
SET DIC("S")="I +Y,(+Y<15!(""^24^25^29^34^35^40^41^43^45^47^51^53^54^55^56^57^60^64^65^66^67^68^70^71^72^73^74^75^76^79^80^83^84^85^86^87^88^89^90^91^92^""[(""^""_+Y_""^"")))"
+1 SET Y=0
READ !,"TRANSACTION TYPE: ALL//",X:DTIME
IF '$TEST!(X="^")
QUIT
+2 IF X]""
IF X'="ALL"
DO ^DIC
+3 IF X["?"
WRITE !!,"Enter 'ALL' for all types of transactions in the AR TRANSACTION TYPE FILE",!,"including COMMENTS and STATEMENT DATES.",!
GOTO TYPE
+4 if Y<0
GOTO EXIT1
SET TYP=$SELECT(+Y:+Y,1:X)
+5 IF $PIECE($GET(^PRCA(430.3,+Y,0)),"^",3)>100
WRITE !!,"This is STATUS. Enter a transaction type only."
GOTO TYPE
+6 SET %ZIS="AEQ"
DO ^%ZIS
if POP
GOTO EXIT1
+7 IF $DATA(IO("Q"))
Begin DoDot:1
+8 SET ZTSAVE("DEB")=""
SET ZTSAVE("BDATE")=""
SET ZTSAVE("EDATE")=""
SET ZTSAVE("TYP")=""
SET ZTRTN="DQ^PRCAHIS"
SET ZTDESC="Patient Transaction History Report"
+9 DO ^%ZTLOAD
DO ^%ZISC
DO EXIT1
KILL ZTSAVE,ZTRTN
QUIT
End DoDot:1
QUIT
+10 ;
DQ ;Call to build array of payment transactions
+1 ;
+2 USE IO
+3 DO TRANS^PRCAHIS1
+4 IF '$DATA(^TMP("PRCAGT",$JOB))
WRITE !!,"This patient has no activity during this time period."
+5 IF $DATA(^TMP("PRCAGT",$JOB))
DO HDR
DO PRINT
+6 ;
EXIT1 KILL AMT,BDATE,BN,BN0,CAT,CATCARE,EDATE,EVNTT,DAT1,DAT2,DATE,DEB,DIC,DIR,DIWL,DIWF,DIWR,DIWT,DUOUT,DX,DY,EVNT,EVNTT,LINE,PG,PNODE,TBAL,TOTPRIN,TOTTRAN,TTYP,TYP,TN,TN0,X,Y,Z,ZTSK,^TMP("PRCAGT",$JOB),^UTILITY($JOB)
+1 IF $DATA(DIRUT)!POP
KILL DIRUT,POP
QUIT
+2 ;end of routine
EXIT2 IF $EXTRACT(IOST,1,2)'="C-"
WRITE @IOF
DO ^%ZISC
QUIT
+1 IF $EXTRACT(IOST,1,2)="C-"
WRITE !
DO ENS^%ZISS
SET DY=IOM-1
SET DX=0
XECUTE IOXY
DO KILL^%ZISS
KILL DIR,X,Y,^UTILITY($JOB)
SET DIR(0)="E"
DO ^DIR
+2 IF $DATA(DIRUT)
KILL DIRUT
QUIT
+3 DO ^%ZISC
+4 GOTO EN
+5 ;
+6 ;
PRINT ;Print transactions
+1 KILL DIRUT
+2 SET DATE=0
FOR
SET DATE=$ORDER(^TMP("PRCAGT",$JOB,DEB,DATE))
if 'DATE
QUIT
if $DATA(DIRUT)
QUIT
Begin DoDot:1
+3 SET BN=""
FOR
SET BN=$ORDER(^TMP("PRCAGT",$JOB,DEB,DATE,BN))
if BN=""!($DATA(DIRUT))
QUIT
DO SCRN
Begin DoDot:2
+4 IF $DATA(^TMP("PRCAGT",$JOB,DEB,DATE,0))
SET (BN0,PNODE)=^(0)
Begin DoDot:3
+5 WRITE !,$$FMTE^XLFDT($PIECE(DATE,".")),?16
+6 SET TYP=$PIECE(BN0,"^",2)
WRITE $SELECT(TYP=1:"COMMENT",1:"PATIENT STATEMENT PRINTED")
IF TYP=1
SET EVNT=$PIECE(BN0,"^",3)
Begin DoDot:4
+7 if $DATA(^RC(341,+EVNT,4))
WRITE !,?16,$PIECE(^(4),"^")
+8 IF $ORDER(^RC(341,+EVNT,2,0))
SET EVNTT=0
FOR
SET EVNTT=$ORDER(^RC(341,+EVNT,2,EVNTT))
if 'EVNTT
QUIT
IF $DATA(^(EVNTT,0))
SET X=^(0)
Begin DoDot:5
+9 SET DIWL=17
SET DIWF="WC63"
DO ^DIWP
+10 DO SCRN
End DoDot:5
if $DATA(DIRUT)
QUIT
DO ^DIWW
End DoDot:4
End DoDot:3
+11 if (BN=0)
QUIT
SET TN=""
FOR
SET TN=$ORDER(^TMP("PRCAGT",$JOB,DEB,DATE,BN,TN))
if TN=""
QUIT
if $DATA(DIRUT)
QUIT
DO SCRN
Begin DoDot:3
+12 IF 'TN
IF $DATA(^TMP("PRCAGT",$JOB,DEB,DATE,BN,0))
SET PNODE=^(0)
SET BN0=$GET(^PRCA(430,+BN,0))
WRITE !!,$$FMTE^XLFDT($PIECE(DATE,"."))
Begin DoDot:4
+13 SET CAT=$PIECE(BN0,"^",2)
SET CAT=$SELECT(CAT=24&$PIECE(BN0,"^",16):$PIECE(^PRCA(430.2,$PIECE(BN0,"^",16),0),"^"),1:$PIECE($GET(^PRCA(430.2,+CAT,0)),"^"))
+14 WRITE ?16,CAT," BILL",?56,$PIECE($GET(^PRCA(430,+BN,0)),"^"),?69,$JUSTIFY(+PNODE,10,2)
+15 WRITE !,?16,$PIECE($GET(^PRCA(430.3,+$PIECE(BN0,"^",8),0)),"^")
End DoDot:4
+16 IF TN
SET PNODE=^TMP("PRCAGT",$JOB,DEB,DATE,BN,TN)
WRITE !!,$$FMTE^XLFDT(DATE,"1D"),?16
SET TYP=$PIECE($GET(^PRCA(433,+TN,1)),"^",2)
SET TTYP=$PIECE($GET(^PRCA(430.3,+TYP,0)),U)
WRITE TTYP
Begin DoDot:4
+17 SET CAT=$PIECE($GET(^PRCA(430,+BN,0)),"^",2)
SET CAT=$PIECE($GET(^PRCA(430.2,+CAT,0)),"^")
+18 SET CATCARE=$PIECE($GET(^PRCA(430,+BN,0)),"^",16)
SET CATCARE=$PIECE($GET(^PRCA(430.2,+$PIECE(^(0),"^",16),0)),"^")
End DoDot:4
+19 IF TN
WRITE ?56,$PIECE($GET(^PRCA(430,+BN,0)),"^")
if +TYP'=45
WRITE ?69,$JUSTIFY(+PNODE,10,2)
+20 IF TN
WRITE !?16,CAT
if CATCARE]""
WRITE !,?16,CATCARE
+21 IF TN
IF (+TYP=45)
Begin DoDot:4
+22 IF $DATA(^PRCA(433,+TN,5))
WRITE !?16,$PIECE(^(5),"^",2)
+23 IF $ORDER(^PRCA(433,+TN,7,0))
SET TN0=0
FOR
SET TN0=$ORDER(^PRCA(433,+TN,7,TN0))
if 'TN0
QUIT
IF $DATA(^(TN0,0))
SET X=^(0)
Begin DoDot:5
+24 SET DIWL=17
SET DIWF="C63W"
DO ^DIWP
End DoDot:5
if $DATA(DIRUT)
QUIT
DO ^DIWW
End DoDot:4
+25 DO SCRN
End DoDot:3
+26 QUIT
End DoDot:2
+27 QUIT
End DoDot:1
+28 QUIT
+29 ;
SCRN ;Check for screen
+1 NEW X,Y
KILL DIR
IF ($Y+5)>IOSL
Begin DoDot:1
+2 IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
DO ^DIR
if $DATA(DIRUT)
QUIT
+3 DO HDR
End DoDot:1
+4 QUIT
+5 ;
HDR ;Heading for report
+1 SET PG=PG+1
+2 WRITE @IOF,!,?20,"Patient Transaction History Report",?70,"Page ",PG
+3 WRITE !,?20,"-------------------------------------"
+4 WRITE !!,?18,"For Patient: ",$$NAM^RCFN01(DEB),!,?25,"SSN : ",$$SSN^RCFN01(DEB)
+5 WRITE !,?20,"For dates: ",$$FMTE^XLFDT(BDATE,"1D"),"-",$$FMTE^XLFDT(EDATE,"1D")
+6 WRITE !!," DATE",?16,"ACTIVITY",?56,"BILL #",?73,"AMOUNT",!,LINE
