RCXFMST1 ;ALB/TMK-EDI Lockbox fms transfer (tr) cd sht gen ;31 Mar 03
;;4.5;Accounts Receivable;**173,220,184,238**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
GETTR(RCRECTDA,RCGECSDA) ; extract transfer data for TR code sheet for
; a receipt in rcrectda
; rcgecsda is the ien for the gcs stack file 2100.1 for rebuilds
;
N TRANDA,AMOUNT,DETAIL,UNAPPLY,TOTAL,RCTOTAL,FUND,REVSRCE,VENDORID,RCSEQ,RESULT,GECSDATA,RCTRANS,UNAPPNUM,TRANNUMB
;
; extract all payments on receipt
S RESULT=""
K ^TMP($J,"RCFMSCR") ; used for 215 report, not used here
D FMSLINES^RCXFMSC1(RCRECTDA,1)
K ^TMP($J,"RCFMSCR")
;
; unapplied payments to accounts
S TRANDA=0 F S TRANDA=$O(^RCY(344,RCRECTDA,1,TRANDA)) Q:'TRANDA D
. ; dollars applied in AR
. I $P(^RCY(344,RCRECTDA,1,TRANDA,0),U,5) Q
. ; no dollars on transaction
. S AMOUNT=$P(^RCY(344,RCRECTDA,1,TRANDA,0),U,4) I 'AMOUNT Q
. ;
. S UNAPPLY($$GETUNAPP^RCXFMSCR(RCRECTDA,TRANDA,1))=AMOUNT
;
; no code sheets to send
I '$D(DETAIL),'$D(TOTAL),'$D(UNAPPLY) S RESULT="-1^No code sheets to send for this receipt" G QUIT
;
; get the next common number in the series = station "-" nextnumber
; use (field 200 in file 344) if document previously sent
S TRANNUMB=$P($P($G(^RCY(344,RCRECTDA,2)),U),"-",2)
I TRANNUMB="" S TRANNUMB=$$ENUM^RCMSNUM
I TRANNUMB<0 S RESULT="0^Unable to lookup next transaction number" G QUIT
; remove the dash (i,e, 460-K1A05HY)
S TRANNUMB=$TR(TRANNUMB,"-")
;
; extract transfer from/to array for applied payments
S (RCTOTAL,RCSEQ)=0
S FUND="" F S FUND=$O(TOTAL(FUND)) Q:FUND="" D
. S REVSRCE="" F S REVSRCE=$O(TOTAL(FUND,REVSRCE)) Q:REVSRCE="" D
. . S VENDORID="" F S VENDORID=$O(TOTAL(FUND,REVSRCE,VENDORID)) Q:VENDORID="" D
. . . S RCSEQ=RCSEQ+1,RCTRANS($$TRFUND(),"8NZZ",RCSEQ)=FUND_U_REVSRCE_U_TOTAL(FUND,REVSRCE,VENDORID)_U_U_VENDORID
;
; extract unapplied payments
S UNAPPNUM="" F S UNAPPNUM=$O(UNAPPLY(UNAPPNUM)) Q:UNAPPNUM="" D
. S RCSEQ=RCSEQ+1,RCTRANS($$TRFUND(),"8NZZ",RCSEQ)=3875_U_U_UNAPPLY(UNAPPNUM)_U_UNAPPNUM
;
; build the TR document
S RESULT=$$BUILDTR(.RCTRANS,.DETAIL,+$G(GECSDATA),TRANNUMB,RCRECTDA)
;
QUIT Q RESULT
;
BUILDTR(RCTRANS,RCDETAIL,RCGECSDA,TRANNUMB,RCRECTDA) ; generate a tr code
; sheet for transferring dollars out of 528704/8NZZ
;
; rctrans(fund,rsc,seq) = data array passed
; fund=fund to transfer from (always 528704)
; rsc = rsc to transfer from (always 8NZZ)
; seq = sequence to make record unique for each 'transferred to' rsc
; data = fund to transfer to (piece 1)
; rsc to transfer to (piece 2)
; dollars to transfer (piece 3)
; unapplied deposit # for suspense (fund to transfer to=3875)
; vendor id (piece 5)
;
; rcgecsda is the ien for the gcs stack file 2100.1 for rebuilds
;
; trannumb is the document identifier
;
; rcrectda is the ien of the receipt (file 344)
;
; rcdetail array contains accrual data for BD transactions
;
N COUNT,DATA,DESCRIP,FISCALYR,FUND,GECSFMS,LINE,REVSRCE,TR2,X,Y,RCSUSP,BILLDA,FMSTYPE,AMOUNT,RCSEQ
;
S FISCALYR=$$FY^RCFN01(DT)
;
; build detail lines
S COUNT=0
;
S FMSTYPE="" F S FMSTYPE=$O(RCDETAIL(FMSTYPE)) Q:FMSTYPE="" D
. S BILLDA=0 F S BILLDA=$O(RCDETAIL(FMSTYPE,BILLDA)) Q:'BILLDA D
. . S AMOUNT=RCDETAIL(FMSTYPE,BILLDA)
. . ; Decrease from 528704/8NZZ
. . S COUNT=COUNT+1
. . S LINE(COUNT)=$$DEC(COUNT,FISCALYR,TRANNUMB,AMOUNT)
. . ; Send BD
. . S COUNT=COUNT+1
. . S LINE(COUNT)="LIN^~CRA^"_$S($L(COUNT)=1:"00",$L(COUNT)=2:"0",1:"")_COUNT
. . S $P(LINE(COUNT),U,20)=$J(AMOUNT,0,2)
. . S $P(LINE(COUNT),U,21)="I"
. . S $P(LINE(COUNT),U,23)=$S(FMSTYPE'=75:FMSTYPE,$$GETFUNDB^RCXFMSUF(BILLDA,1)["5287":33,1:75)
. . S $P(LINE(COUNT),U,24)="BD"
. . S $P(LINE(COUNT),U,25)=$TR($P(^PRCA(430,BILLDA,0),U),"-")
. . S $P(LINE(COUNT),U,26)=$$LINE^RCXFMSC1(BILLDA)
. . S $P(LINE(COUNT),U,27)="~"
. ;
;
S FUND=$$TRFUND(),REVSRCE="8NZZ"
S RCSEQ=0 F S RCSEQ=$O(RCTRANS(FUND,REVSRCE,RCSEQ)) Q:'RCSEQ D
. S DATA=RCTRANS(FUND,REVSRCE,RCSEQ)
. ; if no value, quit
. I '$P(DATA,U,3) Q
. ;
. ; create line to transfer from (decrease)
. S COUNT=COUNT+1
. S LINE(COUNT)=$$DEC(COUNT,FISCALYR,TRANNUMB,$P(DATA,U,3))
. ;
. ; create line to transfer to (increase)
. S COUNT=COUNT+1
. S RCSUSP=($P(DATA,U)=3875)
. S LINE(COUNT)="LIN^~CRA^"_$S($L(COUNT)=1:"00",$L(COUNT)=2:"0",1:"")_COUNT
. S $P(LINE(COUNT),U,4)=FISCALYR
. S $P(LINE(COUNT),U,4)=$S($E(FUND,1,4)=5287:"05",1:FISCALYR)
. S $P(LINE(COUNT),U,6)=$P(DATA,U)
. S $P(LINE(COUNT),U,7)=$E(TRANNUMB,1,3) ; station #
. I 'RCSUSP S $P(LINE(COUNT),U,10)=$P(DATA,U,2)
. ;
. ; vendor id
. I 'RCSUSP S $P(LINE(COUNT),U,18)=$P(DATA,U,5)
. ;
. S $P(LINE(COUNT),U,20)=$J($P(DATA,U,3),0,2)
. S $P(LINE(COUNT),U,21)="I"
. S $P(LINE(COUNT),U,23)=$S('RCSUSP:33,1:24)
. S $P(LINE(COUNT),U,24)=$S('RCSUSP:"~",1:"~CRB")
. I RCSUSP D
. . S $P(LINE(COUNT),U,32)=$P(DATA,U,4)
. . S $P(LINE(COUNT),U,33)="~"
;
; build tr2
N FMSDT S FMSDT=$$FMSDATE^RCBEUTRA(DT)
S TR2="CR2^"_$E(FMSDT,2,3)_U_$E(FMSDT,4,5)_U_$E(FMSDT,6,7)_"^^^^^^E^^^"
; deposit number which is equal to the gcs id
; $j(0,0,2) is the document total which is zero
S TR2=TR2_$P(TRANNUMB,U)_"^^"_$J(0,0,2)_"^^"
; deposit/transfer date
S TR2=TR2_$E(DT,2,3)_U_$E(DT,4,5)_U_$E(DT,6,7)_"^~"
;
; put together document in gcs
N D0,DA,DI,DIC,DIE,DIQ2,DQ,DR
S DESCRIP="EDI Lockbox Detail Receipt: "_$P(^RCY(344,RCRECTDA,0),U)
I 'RCGECSDA D CONTROL^GECSUFMS("A",$E(TRANNUMB,1,3),TRANNUMB,"TR",10,0,"",DESCRIP)
I RCGECSDA D REBUILD^GECSUFM1(RCGECSDA,"A",10,"N","Rebuild "_DESCRIP) S GECSFMS("DA")=RCGECSDA
;
; store document in gcs
D SETCS^GECSSTAA(GECSFMS("DA"),TR2)
F COUNT=1:1 Q:'$D(LINE(COUNT)) D SETCS^GECSSTAA(GECSFMS("DA"),LINE(COUNT))
D SETCODE^GECSSDCT(GECSFMS("DA"),"D RETN^RCFMFN02")
D SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
;
; add/update entry in file 347 for unprocessed document report
N %DT,%X,D,DA347,D0,DI,DQ,DIC,ERROR,FMSDOCNO,X
S FMSDOCNO="TR-"_$P(GECSFMS("CTL"),U,9)
S DA347=$O(^RC(347,"C",FMSDOCNO,0))
; if not in the file, addit fmsdocid tr id
I 'DA347 D OPEN^RCFMDRV1(FMSDOCNO,9,"TR-"_$P($G(^RCY(344,RCRECTDA,0)),U),.DA347,.ERROR)
I DA347 D SSTAT^RCFMFN02(FMSDOCNO,1)
;
; return 1 for success ^ fms document id
Q 1_"^TR-"_$P(GECSFMS("CTL"),U,9)
;
;
DEC(COUNT,FISCALYR,TRANNUMB,AMOUNT) ; Add decrease from 528704/8NZZ
; Returns LINE with decrease TR info
; FISCALYR/TRANNUMB from above
; COUNT = line counter
; AMOUNT = amount to be transferred
;
S LINE="LIN^~CRA^"_$S($L(COUNT)=1:"00",$L(COUNT)=2:"0",1:"")_COUNT
S $P(LINE,U,4)=FISCALYR
S $P(LINE,U,6)=$$TRFUND()
S $P(LINE,U,4)=$S($E($P(LINE,U,6),1,4)=5287:"05",1:FISCALYR)
S $P(LINE,U,7)=$E(TRANNUMB,1,3) ; station #
S $P(LINE,U,10)="8NZZ"
;
; vendor id
S $P(LINE,U,18)="MCCFVALUE"
S $P(LINE,U,20)=$J(AMOUNT,0,2)
S $P(LINE,U,21)="D"
S $P(LINE,U,23)=33
S $P(LINE,U,24)="~"
Q LINE
;
TRFUND() ; Determine if fund should be 5287 or 528704, based on date
I DT<3030926 Q 5287
I DT<$$ADDPTEDT^PRCAACC() Q 5287.4
Q 528704
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCXFMST1 7466 printed Dec 13, 2024@01:49:18 Page 2
RCXFMST1 ;ALB/TMK-EDI Lockbox fms transfer (tr) cd sht gen ;31 Mar 03
+1 ;;4.5;Accounts Receivable;**173,220,184,238**;Mar 20, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
GETTR(RCRECTDA,RCGECSDA) ; extract transfer data for TR code sheet for
+1 ; a receipt in rcrectda
+2 ; rcgecsda is the ien for the gcs stack file 2100.1 for rebuilds
+3 ;
+4 NEW TRANDA,AMOUNT,DETAIL,UNAPPLY,TOTAL,RCTOTAL,FUND,REVSRCE,VENDORID,RCSEQ,RESULT,GECSDATA,RCTRANS,UNAPPNUM,TRANNUMB
+5 ;
+6 ; extract all payments on receipt
+7 SET RESULT=""
+8 ; used for 215 report, not used here
KILL ^TMP($JOB,"RCFMSCR")
+9 DO FMSLINES^RCXFMSC1(RCRECTDA,1)
+10 KILL ^TMP($JOB,"RCFMSCR")
+11 ;
+12 ; unapplied payments to accounts
+13 SET TRANDA=0
FOR
SET TRANDA=$ORDER(^RCY(344,RCRECTDA,1,TRANDA))
if 'TRANDA
QUIT
Begin DoDot:1
+14 ; dollars applied in AR
+15 IF $PIECE(^RCY(344,RCRECTDA,1,TRANDA,0),U,5)
QUIT
+16 ; no dollars on transaction
+17 SET AMOUNT=$PIECE(^RCY(344,RCRECTDA,1,TRANDA,0),U,4)
IF 'AMOUNT
QUIT
+18 ;
+19 SET UNAPPLY($$GETUNAPP^RCXFMSCR(RCRECTDA,TRANDA,1))=AMOUNT
End DoDot:1
+20 ;
+21 ; no code sheets to send
+22 IF '$DATA(DETAIL)
IF '$DATA(TOTAL)
IF '$DATA(UNAPPLY)
SET RESULT="-1^No code sheets to send for this receipt"
GOTO QUIT
+23 ;
+24 ; get the next common number in the series = station "-" nextnumber
+25 ; use (field 200 in file 344) if document previously sent
+26 SET TRANNUMB=$PIECE($PIECE($GET(^RCY(344,RCRECTDA,2)),U),"-",2)
+27 IF TRANNUMB=""
SET TRANNUMB=$$ENUM^RCMSNUM
+28 IF TRANNUMB<0
SET RESULT="0^Unable to lookup next transaction number"
GOTO QUIT
+29 ; remove the dash (i,e, 460-K1A05HY)
+30 SET TRANNUMB=$TRANSLATE(TRANNUMB,"-")
+31 ;
+32 ; extract transfer from/to array for applied payments
+33 SET (RCTOTAL,RCSEQ)=0
+34 SET FUND=""
FOR
SET FUND=$ORDER(TOTAL(FUND))
if FUND=""
QUIT
Begin DoDot:1
+35 SET REVSRCE=""
FOR
SET REVSRCE=$ORDER(TOTAL(FUND,REVSRCE))
if REVSRCE=""
QUIT
Begin DoDot:2
+36 SET VENDORID=""
FOR
SET VENDORID=$ORDER(TOTAL(FUND,REVSRCE,VENDORID))
if VENDORID=""
QUIT
Begin DoDot:3
+37 SET RCSEQ=RCSEQ+1
SET RCTRANS($$TRFUND(),"8NZZ",RCSEQ)=FUND_U_REVSRCE_U_TOTAL(FUND,REVSRCE,VENDORID)_U_U_VENDORID
End DoDot:3
End DoDot:2
End DoDot:1
+38 ;
+39 ; extract unapplied payments
+40 SET UNAPPNUM=""
FOR
SET UNAPPNUM=$ORDER(UNAPPLY(UNAPPNUM))
if UNAPPNUM=""
QUIT
Begin DoDot:1
+41 SET RCSEQ=RCSEQ+1
SET RCTRANS($$TRFUND(),"8NZZ",RCSEQ)=3875_U_U_UNAPPLY(UNAPPNUM)_U_UNAPPNUM
End DoDot:1
+42 ;
+43 ; build the TR document
+44 SET RESULT=$$BUILDTR(.RCTRANS,.DETAIL,+$GET(GECSDATA),TRANNUMB,RCRECTDA)
+45 ;
QUIT QUIT RESULT
+1 ;
BUILDTR(RCTRANS,RCDETAIL,RCGECSDA,TRANNUMB,RCRECTDA) ; generate a tr code
+1 ; sheet for transferring dollars out of 528704/8NZZ
+2 ;
+3 ; rctrans(fund,rsc,seq) = data array passed
+4 ; fund=fund to transfer from (always 528704)
+5 ; rsc = rsc to transfer from (always 8NZZ)
+6 ; seq = sequence to make record unique for each 'transferred to' rsc
+7 ; data = fund to transfer to (piece 1)
+8 ; rsc to transfer to (piece 2)
+9 ; dollars to transfer (piece 3)
+10 ; unapplied deposit # for suspense (fund to transfer to=3875)
+11 ; vendor id (piece 5)
+12 ;
+13 ; rcgecsda is the ien for the gcs stack file 2100.1 for rebuilds
+14 ;
+15 ; trannumb is the document identifier
+16 ;
+17 ; rcrectda is the ien of the receipt (file 344)
+18 ;
+19 ; rcdetail array contains accrual data for BD transactions
+20 ;
+21 NEW COUNT,DATA,DESCRIP,FISCALYR,FUND,GECSFMS,LINE,REVSRCE,TR2,X,Y,RCSUSP,BILLDA,FMSTYPE,AMOUNT,RCSEQ
+22 ;
+23 SET FISCALYR=$$FY^RCFN01(DT)
+24 ;
+25 ; build detail lines
+26 SET COUNT=0
+27 ;
+28 SET FMSTYPE=""
FOR
SET FMSTYPE=$ORDER(RCDETAIL(FMSTYPE))
if FMSTYPE=""
QUIT
Begin DoDot:1
+29 SET BILLDA=0
FOR
SET BILLDA=$ORDER(RCDETAIL(FMSTYPE,BILLDA))
if 'BILLDA
QUIT
Begin DoDot:2
+30 SET AMOUNT=RCDETAIL(FMSTYPE,BILLDA)
+31 ; Decrease from 528704/8NZZ
+32 SET COUNT=COUNT+1
+33 SET LINE(COUNT)=$$DEC(COUNT,FISCALYR,TRANNUMB,AMOUNT)
+34 ; Send BD
+35 SET COUNT=COUNT+1
+36 SET LINE(COUNT)="LIN^~CRA^"_$SELECT($LENGTH(COUNT)=1:"00",$LENGTH(COUNT)=2:"0",1:"")_COUNT
+37 SET $PIECE(LINE(COUNT),U,20)=$JUSTIFY(AMOUNT,0,2)
+38 SET $PIECE(LINE(COUNT),U,21)="I"
+39 SET $PIECE(LINE(COUNT),U,23)=$SELECT(FMSTYPE'=75:FMSTYPE,$$GETFUNDB^RCXFMSUF(BILLDA,1)["5287":33,1:75)
+40 SET $PIECE(LINE(COUNT),U,24)="BD"
+41 SET $PIECE(LINE(COUNT),U,25)=$TRANSLATE($PIECE(^PRCA(430,BILLDA,0),U),"-")
+42 SET $PIECE(LINE(COUNT),U,26)=$$LINE^RCXFMSC1(BILLDA)
+43 SET $PIECE(LINE(COUNT),U,27)="~"
End DoDot:2
+44 ;
End DoDot:1
+45 ;
+46 SET FUND=$$TRFUND()
SET REVSRCE="8NZZ"
+47 SET RCSEQ=0
FOR
SET RCSEQ=$ORDER(RCTRANS(FUND,REVSRCE,RCSEQ))
if 'RCSEQ
QUIT
Begin DoDot:1
+48 SET DATA=RCTRANS(FUND,REVSRCE,RCSEQ)
+49 ; if no value, quit
+50 IF '$PIECE(DATA,U,3)
QUIT
+51 ;
+52 ; create line to transfer from (decrease)
+53 SET COUNT=COUNT+1
+54 SET LINE(COUNT)=$$DEC(COUNT,FISCALYR,TRANNUMB,$PIECE(DATA,U,3))
+55 ;
+56 ; create line to transfer to (increase)
+57 SET COUNT=COUNT+1
+58 SET RCSUSP=($PIECE(DATA,U)=3875)
+59 SET LINE(COUNT)="LIN^~CRA^"_$SELECT($LENGTH(COUNT)=1:"00",$LENGTH(COUNT)=2:"0",1:"")_COUNT
+60 SET $PIECE(LINE(COUNT),U,4)=FISCALYR
+61 SET $PIECE(LINE(COUNT),U,4)=$SELECT($EXTRACT(FUND,1,4)=5287:"05",1:FISCALYR)
+62 SET $PIECE(LINE(COUNT),U,6)=$PIECE(DATA,U)
+63 ; station #
SET $PIECE(LINE(COUNT),U,7)=$EXTRACT(TRANNUMB,1,3)
+64 IF 'RCSUSP
SET $PIECE(LINE(COUNT),U,10)=$PIECE(DATA,U,2)
+65 ;
+66 ; vendor id
+67 IF 'RCSUSP
SET $PIECE(LINE(COUNT),U,18)=$PIECE(DATA,U,5)
+68 ;
+69 SET $PIECE(LINE(COUNT),U,20)=$JUSTIFY($PIECE(DATA,U,3),0,2)
+70 SET $PIECE(LINE(COUNT),U,21)="I"
+71 SET $PIECE(LINE(COUNT),U,23)=$SELECT('RCSUSP:33,1:24)
+72 SET $PIECE(LINE(COUNT),U,24)=$SELECT('RCSUSP:"~",1:"~CRB")
+73 IF RCSUSP
Begin DoDot:2
+74 SET $PIECE(LINE(COUNT),U,32)=$PIECE(DATA,U,4)
+75 SET $PIECE(LINE(COUNT),U,33)="~"
End DoDot:2
End DoDot:1
+76 ;
+77 ; build tr2
+78 NEW FMSDT
SET FMSDT=$$FMSDATE^RCBEUTRA(DT)
+79 SET TR2="CR2^"_$EXTRACT(FMSDT,2,3)_U_$EXTRACT(FMSDT,4,5)_U_$EXTRACT(FMSDT,6,7)_"^^^^^^E^^^"
+80 ; deposit number which is equal to the gcs id
+81 ; $j(0,0,2) is the document total which is zero
+82 SET TR2=TR2_$PIECE(TRANNUMB,U)_"^^"_$JUSTIFY(0,0,2)_"^^"
+83 ; deposit/transfer date
+84 SET TR2=TR2_$EXTRACT(DT,2,3)_U_$EXTRACT(DT,4,5)_U_$EXTRACT(DT,6,7)_"^~"
+85 ;
+86 ; put together document in gcs
+87 NEW D0,DA,DI,DIC,DIE,DIQ2,DQ,DR
+88 SET DESCRIP="EDI Lockbox Detail Receipt: "_$PIECE(^RCY(344,RCRECTDA,0),U)
+89 IF 'RCGECSDA
DO CONTROL^GECSUFMS("A",$EXTRACT(TRANNUMB,1,3),TRANNUMB,"TR",10,0,"",DESCRIP)
+90 IF RCGECSDA
DO REBUILD^GECSUFM1(RCGECSDA,"A",10,"N","Rebuild "_DESCRIP)
SET GECSFMS("DA")=RCGECSDA
+91 ;
+92 ; store document in gcs
+93 DO SETCS^GECSSTAA(GECSFMS("DA"),TR2)
+94 FOR COUNT=1:1
if '$DATA(LINE(COUNT))
QUIT
DO SETCS^GECSSTAA(GECSFMS("DA"),LINE(COUNT))
+95 DO SETCODE^GECSSDCT(GECSFMS("DA"),"D RETN^RCFMFN02")
+96 DO SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
+97 ;
+98 ; add/update entry in file 347 for unprocessed document report
+99 NEW %DT,%X,D,DA347,D0,DI,DQ,DIC,ERROR,FMSDOCNO,X
+100 SET FMSDOCNO="TR-"_$PIECE(GECSFMS("CTL"),U,9)
+101 SET DA347=$ORDER(^RC(347,"C",FMSDOCNO,0))
+102 ; if not in the file, addit fmsdocid tr id
+103 IF 'DA347
DO OPEN^RCFMDRV1(FMSDOCNO,9,"TR-"_$PIECE($GET(^RCY(344,RCRECTDA,0)),U),.DA347,.ERROR)
+104 IF DA347
DO SSTAT^RCFMFN02(FMSDOCNO,1)
+105 ;
+106 ; return 1 for success ^ fms document id
+107 QUIT 1_"^TR-"_$PIECE(GECSFMS("CTL"),U,9)
+108 ;
+109 ;
DEC(COUNT,FISCALYR,TRANNUMB,AMOUNT) ; Add decrease from 528704/8NZZ
+1 ; Returns LINE with decrease TR info
+2 ; FISCALYR/TRANNUMB from above
+3 ; COUNT = line counter
+4 ; AMOUNT = amount to be transferred
+5 ;
+6 SET LINE="LIN^~CRA^"_$SELECT($LENGTH(COUNT)=1:"00",$LENGTH(COUNT)=2:"0",1:"")_COUNT
+7 SET $PIECE(LINE,U,4)=FISCALYR
+8 SET $PIECE(LINE,U,6)=$$TRFUND()
+9 SET $PIECE(LINE,U,4)=$SELECT($EXTRACT($PIECE(LINE,U,6),1,4)=5287:"05",1:FISCALYR)
+10 ; station #
SET $PIECE(LINE,U,7)=$EXTRACT(TRANNUMB,1,3)
+11 SET $PIECE(LINE,U,10)="8NZZ"
+12 ;
+13 ; vendor id
+14 SET $PIECE(LINE,U,18)="MCCFVALUE"
+15 SET $PIECE(LINE,U,20)=$JUSTIFY(AMOUNT,0,2)
+16 SET $PIECE(LINE,U,21)="D"
+17 SET $PIECE(LINE,U,23)=33
+18 SET $PIECE(LINE,U,24)="~"
+19 QUIT LINE
+20 ;
TRFUND() ; Determine if fund should be 5287 or 528704, based on date
+1 IF DT<3030926
QUIT 5287
+2 IF DT<$$ADDPTEDT^PRCAACC()
QUIT 5287.4
+3 QUIT 528704
+4 ;
