RCXVDC ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03
;;4.5;Accounts Receivable;**201,228,256**;Mar 20, 1995;Build 6
;;Per VHA Directive 2004-038, this routine should not be modified.
;
Q
EN ; Entry Point
NEW RCXVD0,RCXVEVDT,RCXVBCN
NEW RCXVI,RCXVCP,RCXVPC,RCXVPFDT,RCXVPTDT
NEW RCXVBLNA,RCXVBLNB,RCXVICN
I DFN="" S DFN=$P($G(^PRCA(430,RCXVBLN,0)),U,7) ;
K ^TMP($J)
D D430^RCXVDC1
I DFN'="" D D2^RCXVDC2
D D399^RCXVDC3
D D399PC^RCXVDC4
D D350^RCXVDC5
D D3625^RCXVDC7
I RCXVRT="D"!(RCXVRT="C")!(RCXVRT="E") D D433^RCXVDC6
I RCXVRT="H" D D433B^RCXVDC6
;
FILE ;
W "REC:"_RCXVBLNA,!
W "430:"_$G(^TMP($J,RCXVBLN,"1-430A"))_RCXVU
W $G(^TMP($J,RCXVBLN,"1-430B"))_RCXVU
W $G(^TMP($J,RCXVBLN,"1-430C"))
W !
I DFN'="" W "2:"_$G(^TMP($J,RCXVBLN,"2-2A"))_RCXVU_$G(^TMP($J,RCXVBLN,"2-2B")),!
I $G(^TMP($J,RCXVBLN,"3-399A"))'="" W "399:"_^TMP($J,RCXVBLN,"3-399A")_RCXVU_^TMP($J,RCXVBLN,"3-399B")_RCXVU_^TMP($J,RCXVBLN,"3-399C")_RCXVU_^TMP($J,RCXVBLN,"3-399D"),!
S RCXVPC=0
F S RCXVPC=$O(^TMP($J,RCXVBLN,"4-399A",RCXVPC)) Q:'RCXVPC D
. I $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC))'="" D
.. W "399.0304:"
.. W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC))
.. W RCXVU
.. F RCXVCP=1:1 Q:('$D(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP))) D
... I RCXVCP>1 W "~"
... W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP))
... Q
.. W !
. I $G(^TMP($J,RCXVBLN,"4-399B",RCXVPC))'="" W "399.042:"_$G(^TMP($J,RCXVBLN,"4-399B",RCXVPC)),!
. Q
S RCXVI=""
F S RCXVI=$O(^TMP($J,RCXVBLN,"5-350A",RCXVI)) Q:RCXVI="" D
. W "350:"_^TMP($J,RCXVBLN,"5-350A",RCXVI),!
S RCXVI=""
F S RCXVI=$O(^TMP($J,RCXVBLN,"7-362.5A",RCXVI)) Q:RCXVI="" D
. W "362.5:"_^TMP($J,RCXVBLN,"7-362.5A",RCXVI),!
; LOOP THRU ^TMP($J,RCXVBLN,"6-433A",RCXVI)
S RCXVI=""
F S RCXVI=$O(^TMP($J,RCXVBLN,"6-433A",RCXVI)) Q:RCXVI="" D
. W "433:"_$G(^TMP($J,RCXVBLN,"6-433A",RCXVI)),!
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCXVDC 1915 printed Nov 22, 2024@16:59:41 Page 2
RCXVDC ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03
+1 ;;4.5;Accounts Receivable;**201,228,256**;Mar 20, 1995;Build 6
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 QUIT
EN ; Entry Point
+1 NEW RCXVD0,RCXVEVDT,RCXVBCN
+2 NEW RCXVI,RCXVCP,RCXVPC,RCXVPFDT,RCXVPTDT
+3 NEW RCXVBLNA,RCXVBLNB,RCXVICN
+4 ;
IF DFN=""
SET DFN=$PIECE($GET(^PRCA(430,RCXVBLN,0)),U,7)
+5 KILL ^TMP($JOB)
+6 DO D430^RCXVDC1
+7 IF DFN'=""
DO D2^RCXVDC2
+8 DO D399^RCXVDC3
+9 DO D399PC^RCXVDC4
+10 DO D350^RCXVDC5
+11 DO D3625^RCXVDC7
+12 IF RCXVRT="D"!(RCXVRT="C")!(RCXVRT="E")
DO D433^RCXVDC6
+13 IF RCXVRT="H"
DO D433B^RCXVDC6
+14 ;
FILE ;
+1 WRITE "REC:"_RCXVBLNA,!
+2 WRITE "430:"_$GET(^TMP($JOB,RCXVBLN,"1-430A"))_RCXVU
+3 WRITE $GET(^TMP($JOB,RCXVBLN,"1-430B"))_RCXVU
+4 WRITE $GET(^TMP($JOB,RCXVBLN,"1-430C"))
+5 WRITE !
+6 IF DFN'=""
WRITE "2:"_$GET(^TMP($JOB,RCXVBLN,"2-2A"))_RCXVU_$GET(^TMP($JOB,RCXVBLN,"2-2B")),!
+7 IF $GET(^TMP($JOB,RCXVBLN,"3-399A"))'=""
WRITE "399:"_^TMP($JOB,RCXVBLN,"3-399A")_RCXVU_^TMP($JOB,RCXVBLN,"3-399B")_RCXVU_^TMP($JOB,RCXVBLN,"3-399C")_RCXVU_^TMP($JOB,RCXVBLN,"3-399D"),!
+8 SET RCXVPC=0
+9 FOR
SET RCXVPC=$ORDER(^TMP($JOB,RCXVBLN,"4-399A",RCXVPC))
if 'RCXVPC
QUIT
Begin DoDot:1
+10 IF $GET(^TMP($JOB,RCXVBLN,"4-399A",RCXVPC))'=""
Begin DoDot:2
+11 WRITE "399.0304:"
+12 WRITE $GET(^TMP($JOB,RCXVBLN,"4-399A",RCXVPC))
+13 WRITE RCXVU
+14 FOR RCXVCP=1:1
if ('$DATA(^TMP($JOB,RCXVBLN,"4-399A",RCXVPC,RCXVCP)))
QUIT
Begin DoDot:3
+15 IF RCXVCP>1
WRITE "~"
+16 WRITE $GET(^TMP($JOB,RCXVBLN,"4-399A",RCXVPC,RCXVCP))
+17 QUIT
End DoDot:3
+18 WRITE !
End DoDot:2
+19 IF $GET(^TMP($JOB,RCXVBLN,"4-399B",RCXVPC))'=""
WRITE "399.042:"_$GET(^TMP($JOB,RCXVBLN,"4-399B",RCXVPC)),!
+20 QUIT
End DoDot:1
+21 SET RCXVI=""
+22 FOR
SET RCXVI=$ORDER(^TMP($JOB,RCXVBLN,"5-350A",RCXVI))
if RCXVI=""
QUIT
Begin DoDot:1
+23 WRITE "350:"_^TMP($JOB,RCXVBLN,"5-350A",RCXVI),!
End DoDot:1
+24 SET RCXVI=""
+25 FOR
SET RCXVI=$ORDER(^TMP($JOB,RCXVBLN,"7-362.5A",RCXVI))
if RCXVI=""
QUIT
Begin DoDot:1
+26 WRITE "362.5:"_^TMP($JOB,RCXVBLN,"7-362.5A",RCXVI),!
End DoDot:1
+27 ; LOOP THRU ^TMP($J,RCXVBLN,"6-433A",RCXVI)
+28 SET RCXVI=""
+29 FOR
SET RCXVI=$ORDER(^TMP($JOB,RCXVBLN,"6-433A",RCXVI))
if RCXVI=""
QUIT
Begin DoDot:1
+30 WRITE "433:"_$GET(^TMP($JOB,RCXVBLN,"6-433A",RCXVI)),!
+31 QUIT
End DoDot:1
+32 QUIT
