RCXFMSWR ;WISC/RFJ-fms writeoff (wr) code sheet generator ;1 Nov 97
;;4.5;Accounts Receivable;**96,135,98,156,170,191,220,184**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
STARTWR(RCDATEND) ; top entry point to generate a wr code sheet
;
; rcdatend is the ending date of the period.
; This date is the 3rd work day from the end of the month.
; The utility $$LDATE^RCRJR is used to figure it out. It will
; change from month to month and figures in holidays also.
; For example, if running the ARDC for the month of June 2003
; the EOAM will calculate out to be June 25, 2003.
; This is called by the background monthly data collector
;
; data stored in tmp($j,rcrjrcolwr,type,revsourcecode)
; this is called by the background monthly data collector
;
N GECSDATA,RCTRANID,RESULT
; lookup fms document number to see if the monthly sv has been sent
; example rcdatend=3010531, lookup on 3010500
D KEYLOOK^GECSSGET("WR-"_$E(RCDATEND,1,5)_"00",1)
;
; get the transacion id for the fms document
; if it is not sent, get the next number available
I $G(GECSDATA) S RCTRANID=$E($P(GECSDATA("2100.1",GECSDATA,".01","E"),"-",2),1,11)
I $G(RCTRANID)="" S RCTRANID=$$ENUM^RCMSNUM
I RCTRANID<0 Q ;unable to retrieve the next number
; remove dash (example 460-K1A05HY)
S RCTRANID=$TR(RCTRANID,"-")
;
; build and send the sv document to fms
S RESULT=$$BUILDWR(RCDATEND,+$G(GECSDATA),RCTRANID)
; error in building code sheet
I 'RESULT Q
;
; add/update entry in file 347 for reports
N %DT,%X,D,D0,DA347,DI,DQ,DIC,ERROR
S DA347=$O(^RC(347,"D","WR-"_$E(RCDATEND,1,5)_"00",0))
; if not in the file, addit fmsdocid wr id
I 'DA347 D OPEN^RCFMDRV1($P(RESULT,"^",2),8,"WR-"_$E(RCDATEND,1,5)_"00",.DA347,.ERROR)
I DA347 D SSTAT^RCFMFN02($P(RESULT,"^",2),1)
Q
;
;
BUILDWR(RCDATEND,RCGECSDA,RCTRANID) ; generate a wr code sheet for monthly data
; rcgecsda is the ien for the gcs stack file 2100.1 for rebuilds
; data stored in tmp($j,rcrjrcolwr)
;
N AMOUNT,COUNT,CR2,DESCRIP,DOCTOTAL,FISCALYR,FMSLINE,FUND,GECSFMS,RSC,TYPE
;
S FISCALYR=$$FY^RCFN01(RCDATEND)
;
S COUNT=0,DOCTOTAL=0
S TYPE="" F S TYPE=$O(^TMP($J,"RCRJRCOLWR",TYPE)) Q:TYPE="" D
. S FUND="" F S FUND=$O(^TMP($J,"RCRJRCOLWR",TYPE,FUND)) Q:FUND="" D
. . S RSC="" F S RSC=$O(^TMP($J,"RCRJRCOLWR",TYPE,FUND,RSC)) Q:RSC="" D
. . . S AMOUNT=^TMP($J,"RCRJRCOLWR",TYPE,FUND,RSC),DOCTOTAL=DOCTOTAL+AMOUNT
. . . I AMOUNT=0 Q
. . . S COUNT=COUNT+1
. . . S FMSLINE(COUNT)="LIN^~CRA^"_$S($L(COUNT)=1:"00",$L(COUNT)=2:"0",1:"")_COUNT
. . . ;S $P(FMSLINE(COUNT),"^",4)=$S(FUND=4032:"03",1:FISCALYR) ;begin fy
. . . S $P(FMSLINE(COUNT),"^",4)=FISCALYR ;begin fy
. . . S $P(FMSLINE(COUNT),"^",4)=$S($E(FUND,1,4)=5287:"05",1:FISCALYR) ;begin fy
. . . S $P(FMSLINE(COUNT),"^",6)=FUND
. . . S $P(FMSLINE(COUNT),"^",7)=$E(RCTRANID,1,3) ;site number
. . . S $P(FMSLINE(COUNT),"^",10)=RSC
. . . ;
. . . ; vendor id
. . . S $P(FMSLINE(COUNT),"^",18)="MCCFVALUE"
. . . I FUND=4032!(FUND=528709) S $P(FMSLINE(COUNT),"^",18)="EXCFVALUE"
. . . ; for transaction type P4, send vendorid of PERSONOTH
. . . I TYPE="P4" S $P(FMSLINE(COUNT),"^",18)="PERSONOTH"
. . . ;
. . . S $P(FMSLINE(COUNT),"^",20)=$J(AMOUNT,0,2)
. . . S $P(FMSLINE(COUNT),"^",21)="I"
. . . S $P(FMSLINE(COUNT),"^",23)=TYPE_"^~"
;
; no code sheets to send
I COUNT=0 Q "0^No wr code sheets to send for this month"
;
S CR2="CR2^"_$E(RCDATEND,2,3)_"^"_$E(RCDATEND,4,5)_"^"_$E(RCDATEND,6,7)
S $P(CR2,"^",10)="E"
S $P(CR2,"^",13)=999999999999
S $P(CR2,"^",15)=$J(DOCTOTAL,0,2)
S $P(CR2,"^",17)=$E(RCDATEND,2,3)
S $P(CR2,"^",18)=$E(RCDATEND,4,5)
S $P(CR2,"^",19)=$E(RCDATEND,6,7)_"^~"
;
; put together document in gcs
N %DT,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
S Y=$E(RCDATEND,1,5)_"00" D DD^%DT
S DESCRIP="Monthly Write Off for "_Y
I 'RCGECSDA D CONTROL^GECSUFMS("A",$E(RCTRANID,1,3),RCTRANID,"WR",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"),CR2)
F COUNT=1:1 Q:'$D(FMSLINE(COUNT)) D SETCS^GECSSTAA(GECSFMS("DA"),FMSLINE(COUNT))
D SETCODE^GECSSDCT(GECSFMS("DA"),"D RETN^RCFMFN02")
D SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
; set the key for lookup
D SETKEY^GECSSTAA(GECSFMS("DA"),"WR-"_$E(RCDATEND,1,5)_"00")
;
; return 1 for success ^ fms document transaction number
Q "1^WR-"_$P(GECSFMS("CTL"),"^",9)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCXFMSWR 4726 printed Dec 13, 2024@01:49:25 Page 2
RCXFMSWR ;WISC/RFJ-fms writeoff (wr) code sheet generator ;1 Nov 97
+1 ;;4.5;Accounts Receivable;**96,135,98,156,170,191,220,184**;Mar 20, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
STARTWR(RCDATEND) ; top entry point to generate a wr code sheet
+1 ;
+2 ; rcdatend is the ending date of the period.
+3 ; This date is the 3rd work day from the end of the month.
+4 ; The utility $$LDATE^RCRJR is used to figure it out. It will
+5 ; change from month to month and figures in holidays also.
+6 ; For example, if running the ARDC for the month of June 2003
+7 ; the EOAM will calculate out to be June 25, 2003.
+8 ; This is called by the background monthly data collector
+9 ;
+10 ; data stored in tmp($j,rcrjrcolwr,type,revsourcecode)
+11 ; this is called by the background monthly data collector
+12 ;
+13 NEW GECSDATA,RCTRANID,RESULT
+14 ; lookup fms document number to see if the monthly sv has been sent
+15 ; example rcdatend=3010531, lookup on 3010500
+16 DO KEYLOOK^GECSSGET("WR-"_$EXTRACT(RCDATEND,1,5)_"00",1)
+17 ;
+18 ; get the transacion id for the fms document
+19 ; if it is not sent, get the next number available
+20 IF $GET(GECSDATA)
SET RCTRANID=$EXTRACT($PIECE(GECSDATA("2100.1",GECSDATA,".01","E"),"-",2),1,11)
+21 IF $GET(RCTRANID)=""
SET RCTRANID=$$ENUM^RCMSNUM
+22 ;unable to retrieve the next number
IF RCTRANID<0
QUIT
+23 ; remove dash (example 460-K1A05HY)
+24 SET RCTRANID=$TRANSLATE(RCTRANID,"-")
+25 ;
+26 ; build and send the sv document to fms
+27 SET RESULT=$$BUILDWR(RCDATEND,+$GET(GECSDATA),RCTRANID)
+28 ; error in building code sheet
+29 IF 'RESULT
QUIT
+30 ;
+31 ; add/update entry in file 347 for reports
+32 NEW %DT,%X,D,D0,DA347,DI,DQ,DIC,ERROR
+33 SET DA347=$ORDER(^RC(347,"D","WR-"_$EXTRACT(RCDATEND,1,5)_"00",0))
+34 ; if not in the file, addit fmsdocid wr id
+35 IF 'DA347
DO OPEN^RCFMDRV1($PIECE(RESULT,"^",2),8,"WR-"_$EXTRACT(RCDATEND,1,5)_"00",.DA347,.ERROR)
+36 IF DA347
DO SSTAT^RCFMFN02($PIECE(RESULT,"^",2),1)
+37 QUIT
+38 ;
+39 ;
BUILDWR(RCDATEND,RCGECSDA,RCTRANID) ; generate a wr code sheet for monthly data
+1 ; rcgecsda is the ien for the gcs stack file 2100.1 for rebuilds
+2 ; data stored in tmp($j,rcrjrcolwr)
+3 ;
+4 NEW AMOUNT,COUNT,CR2,DESCRIP,DOCTOTAL,FISCALYR,FMSLINE,FUND,GECSFMS,RSC,TYPE
+5 ;
+6 SET FISCALYR=$$FY^RCFN01(RCDATEND)
+7 ;
+8 SET COUNT=0
SET DOCTOTAL=0
+9 SET TYPE=""
FOR
SET TYPE=$ORDER(^TMP($JOB,"RCRJRCOLWR",TYPE))
if TYPE=""
QUIT
Begin DoDot:1
+10 SET FUND=""
FOR
SET FUND=$ORDER(^TMP($JOB,"RCRJRCOLWR",TYPE,FUND))
if FUND=""
QUIT
Begin DoDot:2
+11 SET RSC=""
FOR
SET RSC=$ORDER(^TMP($JOB,"RCRJRCOLWR",TYPE,FUND,RSC))
if RSC=""
QUIT
Begin DoDot:3
+12 SET AMOUNT=^TMP($JOB,"RCRJRCOLWR",TYPE,FUND,RSC)
SET DOCTOTAL=DOCTOTAL+AMOUNT
+13 IF AMOUNT=0
QUIT
+14 SET COUNT=COUNT+1
+15 SET FMSLINE(COUNT)="LIN^~CRA^"_$SELECT($LENGTH(COUNT)=1:"00",$LENGTH(COUNT)=2:"0",1:"")_COUNT
+16 ;S $P(FMSLINE(COUNT),"^",4)=$S(FUND=4032:"03",1:FISCALYR) ;begin fy
+17 ;begin fy
SET $PIECE(FMSLINE(COUNT),"^",4)=FISCALYR
+18 ;begin fy
SET $PIECE(FMSLINE(COUNT),"^",4)=$SELECT($EXTRACT(FUND,1,4)=5287:"05",1:FISCALYR)
+19 SET $PIECE(FMSLINE(COUNT),"^",6)=FUND
+20 ;site number
SET $PIECE(FMSLINE(COUNT),"^",7)=$EXTRACT(RCTRANID,1,3)
+21 SET $PIECE(FMSLINE(COUNT),"^",10)=RSC
+22 ;
+23 ; vendor id
+24 SET $PIECE(FMSLINE(COUNT),"^",18)="MCCFVALUE"
+25 IF FUND=4032!(FUND=528709)
SET $PIECE(FMSLINE(COUNT),"^",18)="EXCFVALUE"
+26 ; for transaction type P4, send vendorid of PERSONOTH
+27 IF TYPE="P4"
SET $PIECE(FMSLINE(COUNT),"^",18)="PERSONOTH"
+28 ;
+29 SET $PIECE(FMSLINE(COUNT),"^",20)=$JUSTIFY(AMOUNT,0,2)
+30 SET $PIECE(FMSLINE(COUNT),"^",21)="I"
+31 SET $PIECE(FMSLINE(COUNT),"^",23)=TYPE_"^~"
End DoDot:3
End DoDot:2
End DoDot:1
+32 ;
+33 ; no code sheets to send
+34 IF COUNT=0
QUIT "0^No wr code sheets to send for this month"
+35 ;
+36 SET CR2="CR2^"_$EXTRACT(RCDATEND,2,3)_"^"_$EXTRACT(RCDATEND,4,5)_"^"_$EXTRACT(RCDATEND,6,7)
+37 SET $PIECE(CR2,"^",10)="E"
+38 SET $PIECE(CR2,"^",13)=999999999999
+39 SET $PIECE(CR2,"^",15)=$JUSTIFY(DOCTOTAL,0,2)
+40 SET $PIECE(CR2,"^",17)=$EXTRACT(RCDATEND,2,3)
+41 SET $PIECE(CR2,"^",18)=$EXTRACT(RCDATEND,4,5)
+42 SET $PIECE(CR2,"^",19)=$EXTRACT(RCDATEND,6,7)_"^~"
+43 ;
+44 ; put together document in gcs
+45 NEW %DT,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
+46 SET Y=$EXTRACT(RCDATEND,1,5)_"00"
DO DD^%DT
+47 SET DESCRIP="Monthly Write Off for "_Y
+48 IF 'RCGECSDA
DO CONTROL^GECSUFMS("A",$EXTRACT(RCTRANID,1,3),RCTRANID,"WR",10,0,"",DESCRIP)
+49 IF RCGECSDA
DO REBUILD^GECSUFM1(RCGECSDA,"A",10,"N","Rebuild "_DESCRIP)
SET GECSFMS("DA")=RCGECSDA
+50 ;
+51 ; store document in gcs
+52 DO SETCS^GECSSTAA(GECSFMS("DA"),CR2)
+53 FOR COUNT=1:1
if '$DATA(FMSLINE(COUNT))
QUIT
DO SETCS^GECSSTAA(GECSFMS("DA"),FMSLINE(COUNT))
+54 DO SETCODE^GECSSDCT(GECSFMS("DA"),"D RETN^RCFMFN02")
+55 DO SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
+56 ; set the key for lookup
+57 DO SETKEY^GECSSTAA(GECSFMS("DA"),"WR-"_$EXTRACT(RCDATEND,1,5)_"00")
+58 ;
+59 ; return 1 for success ^ fms document transaction number
+60 QUIT "1^WR-"_$PIECE(GECSFMS("CTL"),"^",9)
