- 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 Jan 18, 2025@02:50:48 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