- PRCAGT ;WASH-ISC@ALTOONA,PA/CMS - Patient Statement Build Tran List ;8/19/93
- V ;;4.5;Accounts Receivable;**100,162,165,169,219,301,340,377,381,389**;Mar 20, 1995;Build 36
- ;;Per VA Directive 6402, this routine should not be modified.
- ;SEND (DEB=340-IFN,BEG,END,TRANTYPE=430.3-IFN)
- ;BUILD ^TMP("PRCAGT",$J,DEB,DATE,BILL,TN)=TAMT^TTY
- ;IF (TN,TTY)=0 TAMT=BILL'S ORIG AMT
- ;CALLER MUST KILL ^TMP
- EN(DEB,BEG,END,TTY) ;*CALLER MUST KILL ^TMP("PRCAGT",$J)
- NEW Y,% K ^TMP("PRCAGT",$J)
- S:$G(BEG)="" BEG=0 I $G(END)="" D NOW^%DTC S END=%
- S TTY=$G(TTY) I TTY="" D F430
- D F433
- Q Q
- F430 ;
- NEW DAT,BN
- S DAT=BEG F S DAT=$O(^PRCA(430,"ATD",DEB,DAT)) Q:('DAT)!(DAT>END) S BN=0 F S BN=$O(^PRCA(430,"ATD",DEB,DAT,BN)) Q:'BN D
- .;Q:$D(^PRCA(430,"TCSP",BN)) ;prca*4.5*301
- .I $P(^PRCA(430,BN,0),U,3) S ^TMP("PRCAGT",$J,DEB,DAT,BN,0)=$P(^PRCA(430,BN,0),"^",3)_"^0"
- Q
- F433 ;
- NEW DAT,TN,TN0,TN1,COMM S COMM=0
- F DAT=BEG:0 S DAT=$O(^PRCA(433,"ATD",DEB,DAT)) Q:('DAT)!(DAT>END) F TN=0:0 S TN=$O(^PRCA(433,"ATD",DEB,DAT,TN)) Q:'TN D
- .S TN0=$G(^PRCA(433,TN,0)) Q:TN0="" S TN1=$G(^PRCA(433,TN,1))
- .I $P(TN1,U,2)=45 S COMM=1
- .I $G(TTY)'="" Q:TTY'=$P(TN1,U,2)
- .;PRCA*4.5*377/PRCA*4.5*381/PRCA*4.5*389
- .I TTY="",",3,4,5,6,7,24,30,"[(","_$P(TN1,U,2)_",") Q
- .I ($P(TN0,U,2)="")!($P(TN0,U,4)'=2) Q
- .I $G(PRCAHIST)="THIST",$P(TN1,U,2)=45 G F433A
- .I $P(TN0,U,10)=1 Q
- .;
- .; if transaction type not 46 (unsuspended) and not 47 (suspended)
- .; then check to see if the bill was suspended or unsuspended at the
- .; time the transaction was entered. if the bill is suspended, then
- .; the transaction should not be counted. if the bill is unsuspended
- .; then the transaction should be counted.
- .I $P(TN1,"^",2)'=46,$P(TN1,"^",2)'=47 D I TN1="" Q
- . . N RCTRANDA,RCSTOP,TRANTYPE
- . . ; check to see if bill was unsuspended when transaction was created
- . . ; if so, count the transaction
- . . S RCSTOP=0
- . . S RCTRANDA=TN F S RCTRANDA=$O(^PRCA(433,"C",+$P(TN0,"^",2),RCTRANDA),-1) Q:'RCTRANDA D I RCSTOP Q
- . . . ; transaction not complete
- . . . I $P($G(^PRCA(433,RCTRANDA,0)),"^",4)'=2 Q
- . . . S TRANTYPE=$P($G(^PRCA(433,RCTRANDA,1)),"^",2)
- . . . ; transaction type is unsuspended (46) meaning the bill
- . . . ; was unsuspended when the transaction was created. the
- . . . ; transaction should be counted.
- . . . I TRANTYPE=46 S RCSTOP=1 Q
- . . . ; transaction type is suspended (47) meaning the bill
- . . . ; was suspended when the transaction was created. the
- . . . ; transaction should not be counted.
- . . . I TRANTYPE=47 S RCSTOP=1,TN1="" Q
- .;
- .I TTY="",+$P(TN1,U,5)=0,$P(TN1,U,2)'=45 Q
- F433A .S ^TMP("PRCAGT",$J,DEB,DAT,$P(TN0,U,2),TN)=+$P(TN1,U,5)_U_$P(TN1,U,2)
- S DAT=0 F S DAT=$O(^TMP("PRCAGT",$J,DEB,DAT)) Q:'DAT S END=DAT
- Q
- TBAL(DEB,TBAL) ;get balance of transactions
- NEW BN,CH,DAT,PC,RF,RR,TAMT,TN,TTY,CS,CSFLAG
- S RR=+$O(^PRCA(430.2,"AC",33,0)),(CH,RF,PC)=0,CSFLAG=$D(CSTCH)
- I '$D(^TMP("PRCAGT",$J,DEB)) G TBALQ
- F DAT=0:0 S DAT=$O(^TMP("PRCAGT",$J,DEB,DAT)) Q:'DAT F BN=0:0 S BN=$O(^TMP("PRCAGT",$J,DEB,DAT,BN)) Q:'BN D
- .S CS=$D(^PRCA(430,"TCSP",BN)) ; set flag for CS bills
- .I $D(^TMP("PRCAGT",$J,DEB,DAT,BN,0)) S CH=CH+^(0) S:CS CSTCH=$G(CSTCH)+^(0)
- .F TN=0:0 S TN=$O(^TMP("PRCAGT",$J,DEB,DAT,BN,TN)) Q:'TN S TAMT=^(TN),TTY=$P(TAMT,U,2) I TTY'=45 D
- ..I TTY=12!(TTY=74) S:TAMT<0 PC=PC+TAMT S:TAMT'<0 CH=CH+TAMT S:TAMT<0&CS CSTPC=$G(CSTPC)+TAMT S:TAMT'<0 CSTCH=$G(CSTCH)+TAMT
- ..; interest and admin charges may be negative
- ..; this was added in patch 165
- ..I TTY'=13 S TAMT=$TR(+TAMT,"-")
- ..I $P(^PRCA(430,BN,0),U,2)=RR S:TTY=1 PC=PC-TAMT S:TTY=35 CH=CH+TAMT S:TTY=41 RF=RF+TAMT Q
- ..I ",2,8,9,10,11,14,19,47,34,35,29,"[(","_TTY_",") S PC=PC-TAMT S:CS CSTPC=$G(CSTPC)-TAMT Q
- ..I ",1,13,46,43,73,"[(","_TTY_",") S CH=CH+TAMT S:CS CSTCH=$G(CSTCH)+TAMT
- ;
- TBALQ S TBAL("RF")=RF,TBAL("CH")=CH,TBAL("PC")=PC,TBAL=RF+CH+PC
- I 'CSFLAG K CSTCH,CSTPC
- Q
- ACT(DEB,DAT) ;Quit 1 if debtor has activity other than interest
- NEW BN,DATT,TN,TN0,TN1
- S TN=0 F DATT=$P($G(DAT),"."):0 S DATT=$O(^PRCA(430,"ATD",DEB,DATT)) Q:'DATT!(TN) F BN=0:0 S BN=$O(^PRCA(430,"ATD",DEB,DATT,BN)) Q:'BN!(TN) S TN=1 Q
- I TN=1 G Q1
- S BN=0 F DATT=$P($G(DAT),"."):0 S DATT=$O(^PRCA(433,"ATD",DEB,DATT)) Q:'DATT!(BN) F TN=0:0 S TN=$O(^PRCA(433,"ATD",DEB,DATT,TN)) Q:'TN!(BN) D
- .S TN0=$G(^PRCA(433,TN,0)) Q:TN0="" S TN1=$G(^PRCA(433,TN,1))
- .I ($P(TN0,U,4)=1)!($P(TN0,U,10)=1) Q
- .I +$P(TN1,U,5)=0,$P(TN1,U,2)'=45 Q
- .I +$P(TN1,U,2)'=13 S BN=1 Q
- I BN=1 G Q1
- Q0 Q 0
- Q1 Q 1
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAGT 4666 printed Jan 18, 2025@02:41:01 Page 2
- PRCAGT ;WASH-ISC@ALTOONA,PA/CMS - Patient Statement Build Tran List ;8/19/93
- V ;;4.5;Accounts Receivable;**100,162,165,169,219,301,340,377,381,389**;Mar 20, 1995;Build 36
- +1 ;;Per VA Directive 6402, this routine should not be modified.
- +2 ;SEND (DEB=340-IFN,BEG,END,TRANTYPE=430.3-IFN)
- +3 ;BUILD ^TMP("PRCAGT",$J,DEB,DATE,BILL,TN)=TAMT^TTY
- +4 ;IF (TN,TTY)=0 TAMT=BILL'S ORIG AMT
- +5 ;CALLER MUST KILL ^TMP
- EN(DEB,BEG,END,TTY) ;*CALLER MUST KILL ^TMP("PRCAGT",$J)
- +1 NEW Y,%
- KILL ^TMP("PRCAGT",$JOB)
- +2 if $GET(BEG)=""
- SET BEG=0
- IF $GET(END)=""
- DO NOW^%DTC
- SET END=%
- +3 SET TTY=$GET(TTY)
- IF TTY=""
- DO F430
- +4 DO F433
- Q QUIT
- F430 ;
- +1 NEW DAT,BN
- +2 SET DAT=BEG
- FOR
- SET DAT=$ORDER(^PRCA(430,"ATD",DEB,DAT))
- if ('DAT)!(DAT>END)
- QUIT
- SET BN=0
- FOR
- SET BN=$ORDER(^PRCA(430,"ATD",DEB,DAT,BN))
- if 'BN
- QUIT
- Begin DoDot:1
- +3 ;Q:$D(^PRCA(430,"TCSP",BN)) ;prca*4.5*301
- +4 IF $PIECE(^PRCA(430,BN,0),U,3)
- SET ^TMP("PRCAGT",$JOB,DEB,DAT,BN,0)=$PIECE(^PRCA(430,BN,0),"^",3)_"^0"
- End DoDot:1
- +5 QUIT
- F433 ;
- +1 NEW DAT,TN,TN0,TN1,COMM
- SET COMM=0
- +2 FOR DAT=BEG:0
- SET DAT=$ORDER(^PRCA(433,"ATD",DEB,DAT))
- if ('DAT)!(DAT>END)
- QUIT
- FOR TN=0:0
- SET TN=$ORDER(^PRCA(433,"ATD",DEB,DAT,TN))
- if 'TN
- QUIT
- Begin DoDot:1
- +3 SET TN0=$GET(^PRCA(433,TN,0))
- if TN0=""
- QUIT
- SET TN1=$GET(^PRCA(433,TN,1))
- +4 IF $PIECE(TN1,U,2)=45
- SET COMM=1
- +5 IF $GET(TTY)'=""
- if TTY'=$PIECE(TN1,U,2)
- QUIT
- +6 ;PRCA*4.5*377/PRCA*4.5*381/PRCA*4.5*389
- +7 IF TTY=""
- IF ",3,4,5,6,7,24,30,"[(","_$PIECE(TN1,U,2)_",")
- QUIT
- +8 IF ($PIECE(TN0,U,2)="")!($PIECE(TN0,U,4)'=2)
- QUIT
- +9 IF $GET(PRCAHIST)="THIST"
- IF $PIECE(TN1,U,2)=45
- GOTO F433A
- +10 IF $PIECE(TN0,U,10)=1
- QUIT
- +11 ;
- +12 ; if transaction type not 46 (unsuspended) and not 47 (suspended)
- +13 ; then check to see if the bill was suspended or unsuspended at the
- +14 ; time the transaction was entered. if the bill is suspended, then
- +15 ; the transaction should not be counted. if the bill is unsuspended
- +16 ; then the transaction should be counted.
- +17 IF $PIECE(TN1,"^",2)'=46
- IF $PIECE(TN1,"^",2)'=47
- Begin DoDot:2
- +18 NEW RCTRANDA,RCSTOP,TRANTYPE
- +19 ; check to see if bill was unsuspended when transaction was created
- +20 ; if so, count the transaction
- +21 SET RCSTOP=0
- +22 SET RCTRANDA=TN
- FOR
- SET RCTRANDA=$ORDER(^PRCA(433,"C",+$PIECE(TN0,"^",2),RCTRANDA),-1)
- if 'RCTRANDA
- QUIT
- Begin DoDot:3
- +23 ; transaction not complete
- +24 IF $PIECE($GET(^PRCA(433,RCTRANDA,0)),"^",4)'=2
- QUIT
- +25 SET TRANTYPE=$PIECE($GET(^PRCA(433,RCTRANDA,1)),"^",2)
- +26 ; transaction type is unsuspended (46) meaning the bill
- +27 ; was unsuspended when the transaction was created. the
- +28 ; transaction should be counted.
- +29 IF TRANTYPE=46
- SET RCSTOP=1
- QUIT
- +30 ; transaction type is suspended (47) meaning the bill
- +31 ; was suspended when the transaction was created. the
- +32 ; transaction should not be counted.
- +33 IF TRANTYPE=47
- SET RCSTOP=1
- SET TN1=""
- QUIT
- End DoDot:3
- IF RCSTOP
- QUIT
- End DoDot:2
- IF TN1=""
- QUIT
- +34 ;
- +35 IF TTY=""
- IF +$PIECE(TN1,U,5)=0
- IF $PIECE(TN1,U,2)'=45
- QUIT
- F433A SET ^TMP("PRCAGT",$JOB,DEB,DAT,$PIECE(TN0,U,2),TN)=+$PIECE(TN1,U,5)_U_$PIECE(TN1,U,2)
- End DoDot:1
- +1 SET DAT=0
- FOR
- SET DAT=$ORDER(^TMP("PRCAGT",$JOB,DEB,DAT))
- if 'DAT
- QUIT
- SET END=DAT
- +2 QUIT
- TBAL(DEB,TBAL) ;get balance of transactions
- +1 NEW BN,CH,DAT,PC,RF,RR,TAMT,TN,TTY,CS,CSFLAG
- +2 SET RR=+$ORDER(^PRCA(430.2,"AC",33,0))
- SET (CH,RF,PC)=0
- SET CSFLAG=$DATA(CSTCH)
- +3 IF '$DATA(^TMP("PRCAGT",$JOB,DEB))
- GOTO TBALQ
- +4 FOR DAT=0:0
- SET DAT=$ORDER(^TMP("PRCAGT",$JOB,DEB,DAT))
- if 'DAT
- QUIT
- FOR BN=0:0
- SET BN=$ORDER(^TMP("PRCAGT",$JOB,DEB,DAT,BN))
- if 'BN
- QUIT
- Begin DoDot:1
- +5 ; set flag for CS bills
- SET CS=$DATA(^PRCA(430,"TCSP",BN))
- +6 IF $DATA(^TMP("PRCAGT",$JOB,DEB,DAT,BN,0))
- SET CH=CH+^(0)
- if CS
- SET CSTCH=$GET(CSTCH)+^(0)
- +7 FOR TN=0:0
- SET TN=$ORDER(^TMP("PRCAGT",$JOB,DEB,DAT,BN,TN))
- if 'TN
- QUIT
- SET TAMT=^(TN)
- SET TTY=$PIECE(TAMT,U,2)
- IF TTY'=45
- Begin DoDot:2
- +8 IF TTY=12!(TTY=74)
- if TAMT<0
- SET PC=PC+TAMT
- if TAMT'<0
- SET CH=CH+TAMT
- if TAMT<0&CS
- SET CSTPC=$GET(CSTPC)+TAMT
- if TAMT'<0
- SET CSTCH=$GET(CSTCH)+TAMT
- +9 ; interest and admin charges may be negative
- +10 ; this was added in patch 165
- +11 IF TTY'=13
- SET TAMT=$TRANSLATE(+TAMT,"-")
- +12 IF $PIECE(^PRCA(430,BN,0),U,2)=RR
- if TTY=1
- SET PC=PC-TAMT
- if TTY=35
- SET CH=CH+TAMT
- if TTY=41
- SET RF=RF+TAMT
- QUIT
- +13 IF ",2,8,9,10,11,14,19,47,34,35,29,"[(","_TTY_",")
- SET PC=PC-TAMT
- if CS
- SET CSTPC=$GET(CSTPC)-TAMT
- QUIT
- +14 IF ",1,13,46,43,73,"[(","_TTY_",")
- SET CH=CH+TAMT
- if CS
- SET CSTCH=$GET(CSTCH)+TAMT
- End DoDot:2
- End DoDot:1
- +15 ;
- TBALQ SET TBAL("RF")=RF
- SET TBAL("CH")=CH
- SET TBAL("PC")=PC
- SET TBAL=RF+CH+PC
- +1 IF 'CSFLAG
- KILL CSTCH,CSTPC
- +2 QUIT
- ACT(DEB,DAT) ;Quit 1 if debtor has activity other than interest
- +1 NEW BN,DATT,TN,TN0,TN1
- +2 SET TN=0
- FOR DATT=$PIECE($GET(DAT),"."):0
- SET DATT=$ORDER(^PRCA(430,"ATD",DEB,DATT))
- if 'DATT!(TN)
- QUIT
- FOR BN=0:0
- SET BN=$ORDER(^PRCA(430,"ATD",DEB,DATT,BN))
- if 'BN!(TN)
- QUIT
- SET TN=1
- QUIT
- +3 IF TN=1
- GOTO Q1
- +4 SET BN=0
- FOR DATT=$PIECE($GET(DAT),"."):0
- SET DATT=$ORDER(^PRCA(433,"ATD",DEB,DATT))
- if 'DATT!(BN)
- QUIT
- FOR TN=0:0
- SET TN=$ORDER(^PRCA(433,"ATD",DEB,DATT,TN))
- if 'TN!(BN)
- QUIT
- Begin DoDot:1
- +5 SET TN0=$GET(^PRCA(433,TN,0))
- if TN0=""
- QUIT
- SET TN1=$GET(^PRCA(433,TN,1))
- +6 IF ($PIECE(TN0,U,4)=1)!($PIECE(TN0,U,10)=1)
- QUIT
- +7 IF +$PIECE(TN1,U,5)=0
- IF $PIECE(TN1,U,2)'=45
- QUIT
- +8 IF +$PIECE(TN1,U,2)'=13
- SET BN=1
- QUIT
- End DoDot:1
- +9 IF BN=1
- GOTO Q1
- Q0 QUIT 0
- Q1 QUIT 1