- 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 Mar 13, 2025@20:44:30 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
