- RCXFMSW1 ;WISC/RFJ-fms writeoff (wr) code sheet generator for a transaction ;1 Feb 2000
- ;;4.5;Accounts Receivable;**168,172,204**;Mar 20, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- Q
- ;
- ;
- REGENWR ; regenerate write off document (menu option)
- N FMSDOC,PRINAMT,RCTRANDA,TRANTYPE,Y
- F D Q:'RCTRANDA
- . W ! S RCTRANDA=$$SELTRAN^RCDPTPLM I RCTRANDA<1 S RCTRANDA=0 Q
- . L +^PRCA(433,RCTRANDA):5 I '$T W !,"Another user is working with this transaction. Try again later." Q
- . S TRANTYPE=$P($G(^PRCA(433,RCTRANDA,1)),"^",2)
- . I TRANTYPE'=8,TRANTYPE'=9,TRANTYPE'=10,TRANTYPE'=11,TRANTYPE'=29 L -^PRCA(433,RCTRANDA) W !,"You can only send a WRITE OFF document for transactions that write off a bill." Q
- . ; check to see if transaction was processed
- . I $P($G(^PRCA(433,RCTRANDA,0)),"^",4)'=2 L -^PRCA(433,RCTRANDA) W !,"This transaction was NOT processed." Q
- . D SHOWTRAN(RCTRANDA)
- . I $$ACCK^PRCAACC(+$P($G(^PRCA(433,RCTRANDA,0)),"^",2)) L -^PRCA(433,RCTRANDA) W !,"ACCRUED bills do not get sent in detail to FMS." Q
- . ; get fms document and status
- . S FMSDOC=$$FMSSTAT(RCTRANDA)
- . W !,"Previously sent in WR FMS document: ",$S($P(FMSDOC,"^")="":"NOT FOUND",1:$P(FMSDOC,"^"))," Status: ",$E($P(FMSDOC,"^",2),1,16)
- . I $P(FMSDOC,"^",2)["ACCEPT"!($P(FMSDOC,"^",2)["TRANSMIT") L -^PRCA(433,RCTRANDA) W !,"The FMS document has been ",$P(FMSDOC,"^",2)," and cannot be regenerated." Q
- . S PRINAMT=$P($G(^PRCA(433,RCTRANDA,8)),"^")
- . I PRINAMT'>0 L -^PRCA(433,RCTRANDA) W !,"The principal amount needs to be greater than ZERO." Q
- . S Y=$$ASKOK I Y'=1 L -^PRCA(433,RCTRANDA) S:Y<0 RCTRANDA=0 Q
- . S Y=$$BUILDWR(RCTRANDA)
- . L -^PRCA(433,RCTRANDA)
- . I Y W !,"WR Document regenerated and retransmitted to FMS." Q
- . W !,"Unable to regenerate document. ",$P(Y,"^",2)
- Q
- ;
- ;
- BUILDWR(RCTRANDA) ; this entry point is called to generate a wr document to fms for a single transaction
- N CATEGORY,CR2,DA347,DIQ2,DOCTOTAL,FMSDOCNO,FMSLINE,GECSDATA,RCBILLDA,TRANNUMB,REFMS
- S RCBILLDA=$P($G(^PRCA(433,RCTRANDA,0)),"^",2)
- I 'RCBILLDA Q "0^Bill Number missing on transaction."
- ;
- S DOCTOTAL=$P($G(^PRCA(433,RCTRANDA,8)),"^")
- I 'DOCTOTAL Q "0^Total Principal Amount is ZERO."
- ;
- ; find a previously sent document
- S FMSDOCNO=$P($G(^PRCA(433,RCTRANDA,1)),"^",12) I FMSDOCNO'="" S DA347=$O(^RC(347,"C",FMSDOCNO,0))
- I FMSDOCNO="" D
- . S DA347=$O(^RC(347,"D","T"_RCTRANDA,0)) I 'DA347 Q
- . S FMSDOCNO=$P($G(^RC(347,DA347,0)),"^",9)
- ; if previously sent, get the data from gcs
- I FMSDOCNO'="" S REFMS=1 D DATA^GECSSGET(FMSDOCNO,0) I $G(GECSDATA) S TRANNUMB=$E($P(FMSDOCNO,"-",2),1,11)
- ;
- I $G(TRANNUMB)="" S TRANNUMB=$$ENUM^RCMSNUM
- I TRANNUMB<0 Q "0^Unable to lookup next transaction number."
- ; remove dash (example 460-K1A05HY)
- S TRANNUMB=$TR(TRANNUMB,"-")
- ;
- S FMSLINE="LIN^~CRA^001"
- S $P(FMSLINE,"^",20)=$J(DOCTOTAL,0,2)
- S $P(FMSLINE,"^",21)="I"
- S $P(FMSLINE,"^",23)=$P($$DTYPE^PRCAFBD1($P($G(^PRCA(430,RCBILLDA,11)),"^",10)),"^",4) ;refund/reimbursement
- S $P(FMSLINE,"^",24)="BD"
- S $P(FMSLINE,"^",25)=$TR($P(^PRCA(430,RCBILLDA,0),"^"),"-") ;bill number with no dash
- S $P(FMSLINE,"^",26)=$$LINE^RCXFMSC1(RCBILLDA)_"^~"
- ;
- ; tricare bill
- S CATEGORY=$P($G(^PRCA(430,RCBILLDA,0)),"^",2)
- I CATEGORY=30!(CATEGORY=32) S $P(FMSLINE,"^",23)="06"
- ;
- N FMSDT S FMSDT=$$FMSDATE^RCBEUTRA(DT)
- S CR2="CR2^"_$E(FMSDT,2,3)_"^"_$E(FMSDT,4,5)_"^"_$E(FMSDT,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(DT,2,3)
- S $P(CR2,"^",18)=$E(DT,4,5)
- S $P(CR2,"^",19)=$E(DT,6,7)_"^~"
- ;
- ; put together document in fms
- N %DT,D,D0,DA,DI,DIC,DIE,DQ,DR,GECSFMS,X
- I '$G(GECSDATA) D CONTROL^GECSUFMS("A",$E(TRANNUMB,1,3),TRANNUMB,"WR",10,0,"","WRITE OFF")
- E D REBUILD^GECSUFM1(+GECSDATA,"A",10,"N","Rebuild WRITE OFF") S GECSFMS("DA")=+GECSDATA
- D SETCS^GECSSTAA(GECSFMS("DA"),CR2)
- D SETCS^GECSSTAA(GECSFMS("DA"),FMSLINE)
- D SETCODE^GECSSDCT(GECSFMS("DA"),"D RETN^RCFMFN02")
- D SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
- ;
- ; store the gcs number in 433 for future reference
- S $P(^PRCA(433,RCTRANDA,1),"^",12)="WR-"_$P(GECSFMS("CTL"),"^",9)
- ;
- ; add/update entry in file 347 for reports
- N %DT,X,D,D0,DI,DQ,DIC,ERROR
- I 'DA347 D OPEN^RCFMDRV1("WR-"_$P(GECSFMS("CTL"),"^",9),1,"T"_RCTRANDA,.DA347,.ERROR,RCBILLDA,RCTRANDA)
- I DA347 D SSTAT^RCFMFN02("T"_RCTRANDA,1)
- ;
- Q "1^WR-"_$P(GECSFMS("CTL"),"^",9)
- ;
- ;
- FMSSTAT(RCTRANDA) ; return the fms wr document ^ status ^ file 347 ien
- N DA347,FMSDOCNO,STATUS
- ; get the fms document from the transaction
- S FMSDOCNO=$P($G(^PRCA(433,RCTRANDA,1)),"^",12)
- ; if fms document found, get the file 347 entry
- I FMSDOCNO'="" S DA347=$O(^RC(347,"C",FMSDOCNO,0))
- ; if not on transaction, it may be earlier than patch 146
- I FMSDOCNO="" D
- . S DA347=$O(^RC(347,"D","T"_RCTRANDA,0)) I 'DA347 Q
- . S FMSDOCNO=$P($G(^RC(347,DA347,0)),"^",9)
- ; get the status
- S STATUS="NOT FOUND"
- I FMSDOCNO'="" S STATUS=$$STATUS^GECSSGET(FMSDOCNO)
- Q FMSDOCNO_"^"_STATUS_"^"_$G(DA347)
- ;
- ;
- SHOWTRAN(RCTRANDA) ; show data for transaction
- N DATA0,DATA1,DATA8,RCWRLINE,Y
- S DATA0=$G(^PRCA(433,RCTRANDA,0))
- S DATA1=$G(^PRCA(433,RCTRANDA,1))
- S DATA8=$G(^PRCA(433,RCTRANDA,8))
- S RCWRLINE="",$P(RCWRLINE,"=",79)=""
- W !!,RCWRLINE
- W !,"TRANSACTION NUMBER: ",RCTRANDA
- W ?40,"WAIVED AMOUNT: ",$J($P(DATA1,"^",5),0,2)
- W !,"BILL NUMBER: ",$P($G(^PRCA(430,+$P(DATA0,"^",2),0)),"^")
- S Y=$P($P(DATA1,"^"),".") I Y D DD^%DT
- W ?42,"WAIVED DATE: ",Y
- W !?8,"Principal Waived: ",$J($P(DATA8,"^"),9,2)
- W !?8," Interest Waived: ",$J($P(DATA8,"^",2),9,2)
- W !?8," Admin Waived: ",$J($P(DATA8,"^",3)+$P(DATA8,"^",4)+$P(DATA8,"^",5),9,2)
- W !?26,"---------"
- W !?8," TOTAL Waived: ",$J($P(DATA8,"^")+$P(DATA8,"^",2)+$P(DATA8,"^",3)+$P(DATA8,"^",4)+$P(DATA8,"^",5),9,2)
- W !!,RCWRLINE
- Q
- ;
- ;
- ASKOK() ; ask to regenerate write off document
- N DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
- S DIR(0)="YO",DIR("B")="NO"
- S DIR("A")="Are you sure you want to regenerate the write off document to FMS"
- W ! D ^DIR
- I $G(DTOUT)!($G(DUOUT)) S Y=-1
- Q Y
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCXFMSW1 6229 printed Jan 18, 2025@02:50:37 Page 2
- RCXFMSW1 ;WISC/RFJ-fms writeoff (wr) code sheet generator for a transaction ;1 Feb 2000
- +1 ;;4.5;Accounts Receivable;**168,172,204**;Mar 20, 1995
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 QUIT
- +4 ;
- +5 ;
- REGENWR ; regenerate write off document (menu option)
- +1 NEW FMSDOC,PRINAMT,RCTRANDA,TRANTYPE,Y
- +2 FOR
- Begin DoDot:1
- +3 WRITE !
- SET RCTRANDA=$$SELTRAN^RCDPTPLM
- IF RCTRANDA<1
- SET RCTRANDA=0
- QUIT
- +4 LOCK +^PRCA(433,RCTRANDA):5
- IF '$TEST
- WRITE !,"Another user is working with this transaction. Try again later."
- QUIT
- +5 SET TRANTYPE=$PIECE($GET(^PRCA(433,RCTRANDA,1)),"^",2)
- +6 IF TRANTYPE'=8
- IF TRANTYPE'=9
- IF TRANTYPE'=10
- IF TRANTYPE'=11
- IF TRANTYPE'=29
- LOCK -^PRCA(433,RCTRANDA)
- WRITE !,"You can only send a WRITE OFF document for transactions that write off a bill."
- QUIT
- +7 ; check to see if transaction was processed
- +8 IF $PIECE($GET(^PRCA(433,RCTRANDA,0)),"^",4)'=2
- LOCK -^PRCA(433,RCTRANDA)
- WRITE !,"This transaction was NOT processed."
- QUIT
- +9 DO SHOWTRAN(RCTRANDA)
- +10 IF $$ACCK^PRCAACC(+$PIECE($GET(^PRCA(433,RCTRANDA,0)),"^",2))
- LOCK -^PRCA(433,RCTRANDA)
- WRITE !,"ACCRUED bills do not get sent in detail to FMS."
- QUIT
- +11 ; get fms document and status
- +12 SET FMSDOC=$$FMSSTAT(RCTRANDA)
- +13 WRITE !,"Previously sent in WR FMS document: ",$SELECT($PIECE(FMSDOC,"^")="":"NOT FOUND",1:$PIECE(FMSDOC,"^"))," Status: ",$EXTRACT($PIECE(FMSDOC,"^",2),1,16)
- +14 IF $PIECE(FMSDOC,"^",2)["ACCEPT"!($PIECE(FMSDOC,"^",2)["TRANSMIT")
- LOCK -^PRCA(433,RCTRANDA)
- WRITE !,"The FMS document has been ",$PIECE(FMSDOC,"^",2)," and cannot be regenerated."
- QUIT
- +15 SET PRINAMT=$PIECE($GET(^PRCA(433,RCTRANDA,8)),"^")
- +16 IF PRINAMT'>0
- LOCK -^PRCA(433,RCTRANDA)
- WRITE !,"The principal amount needs to be greater than ZERO."
- QUIT
- +17 SET Y=$$ASKOK
- IF Y'=1
- LOCK -^PRCA(433,RCTRANDA)
- if Y<0
- SET RCTRANDA=0
- QUIT
- +18 SET Y=$$BUILDWR(RCTRANDA)
- +19 LOCK -^PRCA(433,RCTRANDA)
- +20 IF Y
- WRITE !,"WR Document regenerated and retransmitted to FMS."
- QUIT
- +21 WRITE !,"Unable to regenerate document. ",$PIECE(Y,"^",2)
- End DoDot:1
- if 'RCTRANDA
- QUIT
- +22 QUIT
- +23 ;
- +24 ;
- BUILDWR(RCTRANDA) ; this entry point is called to generate a wr document to fms for a single transaction
- +1 NEW CATEGORY,CR2,DA347,DIQ2,DOCTOTAL,FMSDOCNO,FMSLINE,GECSDATA,RCBILLDA,TRANNUMB,REFMS
- +2 SET RCBILLDA=$PIECE($GET(^PRCA(433,RCTRANDA,0)),"^",2)
- +3 IF 'RCBILLDA
- QUIT "0^Bill Number missing on transaction."
- +4 ;
- +5 SET DOCTOTAL=$PIECE($GET(^PRCA(433,RCTRANDA,8)),"^")
- +6 IF 'DOCTOTAL
- QUIT "0^Total Principal Amount is ZERO."
- +7 ;
- +8 ; find a previously sent document
- +9 SET FMSDOCNO=$PIECE($GET(^PRCA(433,RCTRANDA,1)),"^",12)
- IF FMSDOCNO'=""
- SET DA347=$ORDER(^RC(347,"C",FMSDOCNO,0))
- +10 IF FMSDOCNO=""
- Begin DoDot:1
- +11 SET DA347=$ORDER(^RC(347,"D","T"_RCTRANDA,0))
- IF 'DA347
- QUIT
- +12 SET FMSDOCNO=$PIECE($GET(^RC(347,DA347,0)),"^",9)
- End DoDot:1
- +13 ; if previously sent, get the data from gcs
- +14 IF FMSDOCNO'=""
- SET REFMS=1
- DO DATA^GECSSGET(FMSDOCNO,0)
- IF $GET(GECSDATA)
- SET TRANNUMB=$EXTRACT($PIECE(FMSDOCNO,"-",2),1,11)
- +15 ;
- +16 IF $GET(TRANNUMB)=""
- SET TRANNUMB=$$ENUM^RCMSNUM
- +17 IF TRANNUMB<0
- QUIT "0^Unable to lookup next transaction number."
- +18 ; remove dash (example 460-K1A05HY)
- +19 SET TRANNUMB=$TRANSLATE(TRANNUMB,"-")
- +20 ;
- +21 SET FMSLINE="LIN^~CRA^001"
- +22 SET $PIECE(FMSLINE,"^",20)=$JUSTIFY(DOCTOTAL,0,2)
- +23 SET $PIECE(FMSLINE,"^",21)="I"
- +24 ;refund/reimbursement
- SET $PIECE(FMSLINE,"^",23)=$PIECE($$DTYPE^PRCAFBD1($PIECE($GET(^PRCA(430,RCBILLDA,11)),"^",10)),"^",4)
- +25 SET $PIECE(FMSLINE,"^",24)="BD"
- +26 ;bill number with no dash
- SET $PIECE(FMSLINE,"^",25)=$TRANSLATE($PIECE(^PRCA(430,RCBILLDA,0),"^"),"-")
- +27 SET $PIECE(FMSLINE,"^",26)=$$LINE^RCXFMSC1(RCBILLDA)_"^~"
- +28 ;
- +29 ; tricare bill
- +30 SET CATEGORY=$PIECE($GET(^PRCA(430,RCBILLDA,0)),"^",2)
- +31 IF CATEGORY=30!(CATEGORY=32)
- SET $PIECE(FMSLINE,"^",23)="06"
- +32 ;
- +33 NEW FMSDT
- SET FMSDT=$$FMSDATE^RCBEUTRA(DT)
- +34 SET CR2="CR2^"_$EXTRACT(FMSDT,2,3)_"^"_$EXTRACT(FMSDT,4,5)_"^"_$EXTRACT(FMSDT,6,7)
- +35 SET $PIECE(CR2,"^",10)="E"
- +36 SET $PIECE(CR2,"^",13)=999999999999
- +37 SET $PIECE(CR2,"^",15)=$JUSTIFY(DOCTOTAL,0,2)
- +38 SET $PIECE(CR2,"^",17)=$EXTRACT(DT,2,3)
- +39 SET $PIECE(CR2,"^",18)=$EXTRACT(DT,4,5)
- +40 SET $PIECE(CR2,"^",19)=$EXTRACT(DT,6,7)_"^~"
- +41 ;
- +42 ; put together document in fms
- +43 NEW %DT,D,D0,DA,DI,DIC,DIE,DQ,DR,GECSFMS,X
- +44 IF '$GET(GECSDATA)
- DO CONTROL^GECSUFMS("A",$EXTRACT(TRANNUMB,1,3),TRANNUMB,"WR",10,0,"","WRITE OFF")
- +45 IF '$TEST
- DO REBUILD^GECSUFM1(+GECSDATA,"A",10,"N","Rebuild WRITE OFF")
- SET GECSFMS("DA")=+GECSDATA
- +46 DO SETCS^GECSSTAA(GECSFMS("DA"),CR2)
- +47 DO SETCS^GECSSTAA(GECSFMS("DA"),FMSLINE)
- +48 DO SETCODE^GECSSDCT(GECSFMS("DA"),"D RETN^RCFMFN02")
- +49 DO SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
- +50 ;
- +51 ; store the gcs number in 433 for future reference
- +52 SET $PIECE(^PRCA(433,RCTRANDA,1),"^",12)="WR-"_$PIECE(GECSFMS("CTL"),"^",9)
- +53 ;
- +54 ; add/update entry in file 347 for reports
- +55 NEW %DT,X,D,D0,DI,DQ,DIC,ERROR
- +56 IF 'DA347
- DO OPEN^RCFMDRV1("WR-"_$PIECE(GECSFMS("CTL"),"^",9),1,"T"_RCTRANDA,.DA347,.ERROR,RCBILLDA,RCTRANDA)
- +57 IF DA347
- DO SSTAT^RCFMFN02("T"_RCTRANDA,1)
- +58 ;
- +59 QUIT "1^WR-"_$PIECE(GECSFMS("CTL"),"^",9)
- +60 ;
- +61 ;
- FMSSTAT(RCTRANDA) ; return the fms wr document ^ status ^ file 347 ien
- +1 NEW DA347,FMSDOCNO,STATUS
- +2 ; get the fms document from the transaction
- +3 SET FMSDOCNO=$PIECE($GET(^PRCA(433,RCTRANDA,1)),"^",12)
- +4 ; if fms document found, get the file 347 entry
- +5 IF FMSDOCNO'=""
- SET DA347=$ORDER(^RC(347,"C",FMSDOCNO,0))
- +6 ; if not on transaction, it may be earlier than patch 146
- +7 IF FMSDOCNO=""
- Begin DoDot:1
- +8 SET DA347=$ORDER(^RC(347,"D","T"_RCTRANDA,0))
- IF 'DA347
- QUIT
- +9 SET FMSDOCNO=$PIECE($GET(^RC(347,DA347,0)),"^",9)
- End DoDot:1
- +10 ; get the status
- +11 SET STATUS="NOT FOUND"
- +12 IF FMSDOCNO'=""
- SET STATUS=$$STATUS^GECSSGET(FMSDOCNO)
- +13 QUIT FMSDOCNO_"^"_STATUS_"^"_$GET(DA347)
- +14 ;
- +15 ;
- SHOWTRAN(RCTRANDA) ; show data for transaction
- +1 NEW DATA0,DATA1,DATA8,RCWRLINE,Y
- +2 SET DATA0=$GET(^PRCA(433,RCTRANDA,0))
- +3 SET DATA1=$GET(^PRCA(433,RCTRANDA,1))
- +4 SET DATA8=$GET(^PRCA(433,RCTRANDA,8))
- +5 SET RCWRLINE=""
- SET $PIECE(RCWRLINE,"=",79)=""
- +6 WRITE !!,RCWRLINE
- +7 WRITE !,"TRANSACTION NUMBER: ",RCTRANDA
- +8 WRITE ?40,"WAIVED AMOUNT: ",$JUSTIFY($PIECE(DATA1,"^",5),0,2)
- +9 WRITE !,"BILL NUMBER: ",$PIECE($GET(^PRCA(430,+$PIECE(DATA0,"^",2),0)),"^")
- +10 SET Y=$PIECE($PIECE(DATA1,"^"),".")
- IF Y
- DO DD^%DT
- +11 WRITE ?42,"WAIVED DATE: ",Y
- +12 WRITE !?8,"Principal Waived: ",$JUSTIFY($PIECE(DATA8,"^"),9,2)
- +13 WRITE !?8," Interest Waived: ",$JUSTIFY($PIECE(DATA8,"^",2),9,2)
- +14 WRITE !?8," Admin Waived: ",$JUSTIFY($PIECE(DATA8,"^",3)+$PIECE(DATA8,"^",4)+$PIECE(DATA8,"^",5),9,2)
- +15 WRITE !?26,"---------"
- +16 WRITE !?8," TOTAL Waived: ",$JUSTIFY($PIECE(DATA8,"^")+$PIECE(DATA8,"^",2)+$PIECE(DATA8,"^",3)+$PIECE(DATA8,"^",4)+$PIECE(DATA8,"^",5),9,2)
- +17 WRITE !!,RCWRLINE
- +18 QUIT
- +19 ;
- +20 ;
- ASKOK() ; ask to regenerate write off document
- +1 NEW DIR,DIQ2,DIRUT,DTOUT,DUOUT,X,Y
- +2 SET DIR(0)="YO"
- SET DIR("B")="NO"
- +3 SET DIR("A")="Are you sure you want to regenerate the write off document to FMS"
- +4 WRITE !
- DO ^DIR
- +5 IF $GET(DTOUT)!($GET(DUOUT))
- SET Y=-1
- +6 QUIT Y