RCXFMST1.m

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 ---RCXFMST1   7466     printed  Apr 23, 2025@18:03:47                                                                                                                                                                                                    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       ;