source: FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAFWO.m@ 1397

Last change on this file since 1397 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 3.1 KB
Line 
1PRCAFWO ;WASH-ISC@ALTOONA,PA/CLH-FMS WRITE OFF DOCUMENT ;8/2/95 3:20 PM
2V ;;4.5;Accounts Receivable;**16,48,89,90,204**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4EN(BN,DATE,AMOUNT,SITE,TN) ;entry point for auto-creation of FMS write off document
5 NEW GECSFMS,FMSNUM,DA,TYPE,NUM,FMSNUM1 KILL ^TMP("PRCAWR",$J)
6 SET NUM=$PIECE(^PRCA(430,BN,0),U),NUM=$PIECE(NUM,"-")_$PIECE(NUM,"-",2)
7 SET FMSNUM=$$ENUM^RCMSNUM
8 SET TYPE=$$RECTYP^PRCAFUT(BN)
9 DO CONTROL^GECSUFMS("A",SITE,FMSNUM,"WR",10,"","N","WRITE OFF")
10 S FMSNUM1=$P($G(GECSFMS("DOC")),U,3)_"-"_$P($G(GECSFMS("DOC")),U,4)
11 DO OPEN^RCFMDRV1(FMSNUM1,1,"T"_TN,.ENT,.ERR,BN,TN)
12 N FMSDT S FMSDT=$$FMSDATE^RCBEUTRA(DT)
13 SET ^TMP("PRCAWR",$J,1)="CR2^"_$EXTRACT(FMSDT,2,3)_U_$EXTRACT(FMSDT,4,5)_U_$EXTRACT(FMSDT,6,7)_"^^^^^^E^^^999999999999^^"_$JUSTIFY(AMOUNT,0,2)_"^^"_$EXTRACT(DT,2,3)_U_$EXTRACT(DT,4,5)_U_$EXTRACT(DT,6,7)_"^~"
14 I "^30^32^"[("^"_$P($G(^PRCA(430,+BN,0)),"^",2)_"^") S $P(^TMP("PRCAWR",$J,1),"^",15)=$TR($P(^TMP("PRCAWR",$J,1),"^",15),"-","")
15 SET ^TMP("PRCAWR",$J,2)="LIN^~"
16 SET ^TMP("PRCAWR",$J,3)="CRA^001^^^^^^^^^^^^^^^^^"_$JUSTIFY(AMOUNT,0,2)_"^I^^"_$P($$DTYPE^PRCAFBD1(TYPE),U,4)_"^BD^"_NUM_"^"_$$LINE^RCXFMSC1(BN)_"^~"
17 ;Tricare document
18 I "^30^32^"[("^"_$P($G(^PRCA(430,+BN,0)),"^",2)_"^") S $P(^TMP("PRCAWR",$J,3),"^",22)="06",$P(^TMP("PRCAWR",$J,3),"^",19)=$TR($P(^TMP("PRCAWR",$J,3),"^",19),"-","")
19 SET DA=0 FOR SET DA=$ORDER(^TMP("PRCAWR",$J,DA)) QUIT:'DA DO SETCS^GECSSTAA(GECSFMS("DA"),^(DA))
20 DO SETCODE^GECSSDCT(GECSFMS("DA"),"D RETN^RCFMFN02")
21 DO SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
22 DO SSTAT^RCFMFN02("T"_TN,1)
23 WRITE !,"WRITE OFF Document Created. Number # ",GECSFMS("DA"),".",!
24 SET $PIECE(^PRCA(430,BN,11),U,22)=$P(FMSNUM,"-")_$P(FMSNUM,"-",2)
25 KILL ^TMP("PRCAWR",$J)
26 QUIT
27 ;
28MODWR(BN,AMOUNT,FMSNUM,TN,MOD) ;send modified write-off document
29 W !!,"Creating Modified WR document..."
30 NEW GECSFMS,DA,TYPE,NUM,FMSNUM1 KILL ^TMP("PRCAWR",$J)
31 S NUM=$P(^PRCA(430,BN,0),U),NUM=$P(NUM,"-")_$P(NUM,"-",2)
32 S TYPE=$$RECTYP^PRCAFUT(BN)
33 D CONTROL^GECSUFMS("A",$$SITE^RCMSITE,FMSNUM,"WR",10,$S(MOD=1:1,1:""),"N","MODIFIED WRITE OFF")
34 I MOD S FMSNUM1=$P($G(GECSFMS("DOC")),U,3)_"-"_$P($G(GECSFMS("DOC")),U,4)_"-"_$P($G(GECSFMS("BAT")),U,3)
35 D OPEN^RCFMDRV1($S($D(FMSNUM1):FMSNUM1,1:FMSNUM),1,"T"_TN,.ENT,.ERR,BN,TN)
36 N FMSDT S FMSDT=$$FMSDATE^RCBEUTRA(DT)
37 S ^TMP("PRCAWR",$J,1)="CR2^"_$E(FMSDT,2,3)_U_$E(FMSDT,4,5)_U_$E(FMSDT,6,7)_"^^^^^^M^^^999999999999^^"_$J(AMOUNT,0,2)_"^^"_$E(DT,2,3)_U_$E(DT,4,5)_U_$E(DT,6,7)_"^~"
38 S ^TMP("PRCAWR",$J,2)="LIN^~"
39 S ^TMP("PRCAWR",$J,3)="CRA^001^^^^^^^^^^^^^^^^^"_$J(AMOUNT,0,2)_"^D^^"_$P($$DTYPE^PRCAFBD1(TYPE),U,4)_"^BD^"_NUM_"^"_$$LINE^RCXFMSC1(BN)_"^~"
40 S DA=0 FOR S DA=$O(^TMP("PRCAWR",$J,DA)) Q:'DA D SETCS^GECSSTAA(GECSFMS("DA"),^(DA))
41 D SETCODE^GECSSDCT(GECSFMS("DA"),"D RETN^RCFMFN02")
42 D SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
43 D SSTAT^RCFMFN02("T"_TN,1)
44 W !,"Document Created. Number # ",GECSFMS("DA"),".",!
45 I '$G(REFMS)&(DT>$$LDATE^RCRJR(DT)) S Y=$E($$FPS^RCAMFN01(DT,1),1,5)_"01" D DD^%DT W !!," * * * * Transmission will be held until "_Y_" * * * *"
46 S $P(^PRCA(430,BN,11),U,22)=FMSNUM
47 K ^TMP("PRCAWR",$J)
48 Q
49 ;
Note: See TracBrowser for help on using the repository browser.