RCXVDC6 ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03
;;4.5;Accounts Receivable;**201,227,228**;Mar 20, 1995
;
; Accounts Recv. Trans. File (# 433)
Q
D433 ;
K ^TMP($J,RCXVBLN,"6-433A")
N X,Y
; LOOP THRU(^PRCA(433,"C",RCXVBLN)
;
; If the current fiscal year flag is set, must loop for
; all the transactions since the beginning of the fiscal year
I $G(RCXVCFLG)=1 S RCXVBDT=RCXVFFD
NEW RCXVD,RCXVDA,RCXVDT,RCXVI,RCXVP1,RCXVP2,RCXVD0B,RCX
S RCXVD0B=""
F RCXVI=1:1 S RCXVD0B=$O(^PRCA(433,"C",RCXVBLN,RCXVD0B)) Q:RCXVD0B="" D D433A
Q
D433A ;
S RCXVD=$G(^PRCA(433,RCXVD0B,1))
S RCXVP1=$P($G(^PRCA(433,RCXVD0B,0)),U,2),RCXVP2=""
I RCXVP1'="" S RCXVP2=$P($G(^PRCA(430,RCXVP1,0)),U,1)
S RCXVDA=RCXVP2 ; BILL NUMBER (P)
S RCXVDA=RCXVDA_RCXVU_$P($G(^PRCA(433,RCXVD0B,0)),U,1) ; TRANS. #
S RCXVDT=$P(RCXVD,U,9)
I RCXVDT<RCXVBDT Q ;QUIT IF DATE ENTERED IS OLDER THAN BATCH DATE
S RCXVDT=$P(RCXVD,U)
S RCXVDA=RCXVDA_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ; TRANS. DT
S RCXVP1=$P(RCXVD,U,2),RCXVP2=""
I RCXVP1'="",+$P($G(^PRCA(430.3,RCXVP1,0)),U,6)=0 Q
I RCXVP1'="" S RCXVP2=$P($G(^PRCA(430.3,RCXVP1,0)),U,1)
S RCXVDA=RCXVDA_RCXVU_RCXVP2 ; TRANS TYPE (P)
S RCXVDT=$P(RCXVD,U,9)
S RCXVDA=RCXVDA_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ; DT ENTRD
S RCXVDA=RCXVDA_RCXVU_$P(RCXVD,U,5) ; TRANS AMT
S RCXVDA=RCXVDA_RCXVU_$$GET1^DIQ(433,RCXVD0B_",",88,"E") ; CONT. ADJ.
S RCXVDA=RCXVDA_RCXVU_$P(RCXVD,U,3) ;RECEIPT NUMBER
S RCXVDT=$P(RCXVD,U,1)
S RCXVDA=RCXVDA_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ; DT OF PAYMENT
S RCX=0,RCXVDT=""
F S RCX=$O(^PRCA(433,RCXVD0B,7,RCX)) Q:'RCX S X=$G(^(RCX,0)) Q:RCXVDT D
. Q:X'["Check Date: "
. S X=$E(X,13,20) D ^%DT
. I Y S RCXVDT=Y
. Q
S RCXVDA=RCXVDA_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ;CHECK DATE
S ^TMP($J,RCXVBLN,"6-433A",RCXVI)=RCXVDA
Q
;
D433B ;
NEW RCXVDA,RCXVD0B,RCXVI,RQFL
S RCXVD0B="",RQFL=0
F RCXVI=1:1 S RCXVD0B=$O(^PRCA(433,"C",RCXVBLN,RCXVD0B)) Q:RCXVD0B="" D Q:RQFL
. S RCXVDA=$$GET1^DIQ(433,RCXVD0B_",",88,"E") ; Contractual Adj
. I RCXVDA'="" S $P(^TMP($J,RCXVBLN,"6-433A",1),U,7)=RCXVDA,RQFL=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCXVDC6 2156 printed Apr 09, 2024@20:52:50 Page 2
RCXVDC6 ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03
+1 ;;4.5;Accounts Receivable;**201,227,228**;Mar 20, 1995
+2 ;
+3 ; Accounts Recv. Trans. File (# 433)
+4 QUIT
D433 ;
+1 KILL ^TMP($JOB,RCXVBLN,"6-433A")
+2 NEW X,Y
+3 ; LOOP THRU(^PRCA(433,"C",RCXVBLN)
+4 ;
+5 ; If the current fiscal year flag is set, must loop for
+6 ; all the transactions since the beginning of the fiscal year
+7 IF $GET(RCXVCFLG)=1
SET RCXVBDT=RCXVFFD
+8 NEW RCXVD,RCXVDA,RCXVDT,RCXVI,RCXVP1,RCXVP2,RCXVD0B,RCX
+9 SET RCXVD0B=""
+10 FOR RCXVI=1:1
SET RCXVD0B=$ORDER(^PRCA(433,"C",RCXVBLN,RCXVD0B))
if RCXVD0B=""
QUIT
DO D433A
+11 QUIT
D433A ;
+1 SET RCXVD=$GET(^PRCA(433,RCXVD0B,1))
+2 SET RCXVP1=$PIECE($GET(^PRCA(433,RCXVD0B,0)),U,2)
SET RCXVP2=""
+3 IF RCXVP1'=""
SET RCXVP2=$PIECE($GET(^PRCA(430,RCXVP1,0)),U,1)
+4 ; BILL NUMBER (P)
SET RCXVDA=RCXVP2
+5 ; TRANS. #
SET RCXVDA=RCXVDA_RCXVU_$PIECE($GET(^PRCA(433,RCXVD0B,0)),U,1)
+6 SET RCXVDT=$PIECE(RCXVD,U,9)
+7 ;QUIT IF DATE ENTERED IS OLDER THAN BATCH DATE
IF RCXVDT<RCXVBDT
QUIT
+8 SET RCXVDT=$PIECE(RCXVD,U)
+9 ; TRANS. DT
SET RCXVDA=RCXVDA_RCXVU_$EXTRACT($$HLDATE^HLFNC(RCXVDT),1,8)
+10 SET RCXVP1=$PIECE(RCXVD,U,2)
SET RCXVP2=""
+11 IF RCXVP1'=""
IF +$PIECE($GET(^PRCA(430.3,RCXVP1,0)),U,6)=0
QUIT
+12 IF RCXVP1'=""
SET RCXVP2=$PIECE($GET(^PRCA(430.3,RCXVP1,0)),U,1)
+13 ; TRANS TYPE (P)
SET RCXVDA=RCXVDA_RCXVU_RCXVP2
+14 SET RCXVDT=$PIECE(RCXVD,U,9)
+15 ; DT ENTRD
SET RCXVDA=RCXVDA_RCXVU_$EXTRACT($$HLDATE^HLFNC(RCXVDT),1,8)
+16 ; TRANS AMT
SET RCXVDA=RCXVDA_RCXVU_$PIECE(RCXVD,U,5)
+17 ; CONT. ADJ.
SET RCXVDA=RCXVDA_RCXVU_$$GET1^DIQ(433,RCXVD0B_",",88,"E")
+18 ;RECEIPT NUMBER
SET RCXVDA=RCXVDA_RCXVU_$PIECE(RCXVD,U,3)
+19 SET RCXVDT=$PIECE(RCXVD,U,1)
+20 ; DT OF PAYMENT
SET RCXVDA=RCXVDA_RCXVU_$EXTRACT($$HLDATE^HLFNC(RCXVDT),1,8)
+21 SET RCX=0
SET RCXVDT=""
+22 FOR
SET RCX=$ORDER(^PRCA(433,RCXVD0B,7,RCX))
if 'RCX
QUIT
SET X=$GET(^(RCX,0))
if RCXVDT
QUIT
Begin DoDot:1
+23 if X'["Check Date
QUIT
+24 SET X=$EXTRACT(X,13,20)
DO ^%DT
+25 IF Y
SET RCXVDT=Y
+26 QUIT
End DoDot:1
+27 ;CHECK DATE
SET RCXVDA=RCXVDA_RCXVU_$EXTRACT($$HLDATE^HLFNC(RCXVDT),1,8)
+28 SET ^TMP($JOB,RCXVBLN,"6-433A",RCXVI)=RCXVDA
+29 QUIT
+30 ;
D433B ;
+1 NEW RCXVDA,RCXVD0B,RCXVI,RQFL
+2 SET RCXVD0B=""
SET RQFL=0
+3 FOR RCXVI=1:1
SET RCXVD0B=$ORDER(^PRCA(433,"C",RCXVBLN,RCXVD0B))
if RCXVD0B=""
QUIT
Begin DoDot:1
+4 ; Contractual Adj
SET RCXVDA=$$GET1^DIQ(433,RCXVD0B_",",88,"E")
+5 IF RCXVDA'=""
SET $PIECE(^TMP($JOB,RCXVBLN,"6-433A",1),U,7)=RCXVDA
SET RQFL=1
End DoDot:1
if RQFL
QUIT
+6 QUIT
