Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCAFWO

PRCAFWO.m

Go to the documentation of this file. 
  1. PRCAFWO ;WASH-ISC@ALTOONA,PA/CLH-FMS WRITE OFF DOCUMENT  ;8/2/95  3:20 PM
  1. V ;;4.5;Accounts Receivable;**16,48,89,90,204**;Mar 20, 1995
  1.  ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. EN(BN,DATE,AMOUNT,SITE,TN) ;entry point for auto-creation of FMS write off document
  1.  NEW GECSFMS,FMSNUM,DA,TYPE,NUM,FMSNUM1 KILL ^TMP("PRCAWR",$J)
  1.  SET NUM=$PIECE(^PRCA(430,BN,0),U),NUM=$PIECE(NUM,"-")_$PIECE(NUM,"-",2)
  1.  SET FMSNUM=$$ENUM^RCMSNUM
  1.  SET TYPE=$$RECTYP^PRCAFUT(BN)
  1.  DO CONTROL^GECSUFMS("A",SITE,FMSNUM,"WR",10,"","N","WRITE OFF")
  1.  S FMSNUM1=$P($G(GECSFMS("DOC")),U,3)_"-"_$P($G(GECSFMS("DOC")),U,4)
  1.  DO OPEN^RCFMDRV1(FMSNUM1,1,"T"_TN,.ENT,.ERR,BN,TN)
  1.  N FMSDT S FMSDT=$$FMSDATE^RCBEUTRA(DT)
  1.  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)_"^~"
  1.  I "^30^32^"[("^"_$P($G(^PRCA(430,+BN,0)),"^",2)_"^") S $P(^TMP("PRCAWR",$J,1),"^",15)=$TR($P(^TMP("PRCAWR",$J,1),"^",15),"-","")
  1.  SET ^TMP("PRCAWR",$J,2)="LIN^~"
  1.  SET ^TMP("PRCAWR",$J,3)="CRA^001^^^^^^^^^^^^^^^^^"_$JUSTIFY(AMOUNT,0,2)_"^I^^"_$P($$DTYPE^PRCAFBD1(TYPE),U,4)_"^BD^"_NUM_"^"_$$LINE^RCXFMSC1(BN)_"^~"
  1.  ;Tricare document
  1.  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),"-","")
  1.  SET DA=0 FOR  SET DA=$ORDER(^TMP("PRCAWR",$J,DA)) QUIT:'DA  DO SETCS^GECSSTAA(GECSFMS("DA"),^(DA))
  1.  DO SETCODE^GECSSDCT(GECSFMS("DA"),"D RETN^RCFMFN02")
  1.  DO SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
  1.  DO SSTAT^RCFMFN02("T"_TN,1)
  1.  WRITE !,"WRITE OFF Document Created.  Number # ",GECSFMS("DA"),".",!
  1.  SET $PIECE(^PRCA(430,BN,11),U,22)=$P(FMSNUM,"-")_$P(FMSNUM,"-",2)
  1.  KILL ^TMP("PRCAWR",$J)
  1.  QUIT
  1.  ;
  1. MODWR(BN,AMOUNT,FMSNUM,TN,MOD) ;send modified write-off document
  1.  W !!,"Creating Modified WR document..."
  1.  NEW GECSFMS,DA,TYPE,NUM,FMSNUM1 KILL ^TMP("PRCAWR",$J)
  1.  S NUM=$P(^PRCA(430,BN,0),U),NUM=$P(NUM,"-")_$P(NUM,"-",2)
  1.  S TYPE=$$RECTYP^PRCAFUT(BN)
  1.  D CONTROL^GECSUFMS("A",$$SITE^RCMSITE,FMSNUM,"WR",10,$S(MOD=1:1,1:""),"N","MODIFIED WRITE OFF")
  1.  I MOD S FMSNUM1=$P($G(GECSFMS("DOC")),U,3)_"-"_$P($G(GECSFMS("DOC")),U,4)_"-"_$P($G(GECSFMS("BAT")),U,3)
  1.  D OPEN^RCFMDRV1($S($D(FMSNUM1):FMSNUM1,1:FMSNUM),1,"T"_TN,.ENT,.ERR,BN,TN)
  1.  N FMSDT S FMSDT=$$FMSDATE^RCBEUTRA(DT)
  1.  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)_"^~"
  1.  S ^TMP("PRCAWR",$J,2)="LIN^~"
  1.  S ^TMP("PRCAWR",$J,3)="CRA^001^^^^^^^^^^^^^^^^^"_$J(AMOUNT,0,2)_"^D^^"_$P($$DTYPE^PRCAFBD1(TYPE),U,4)_"^BD^"_NUM_"^"_$$LINE^RCXFMSC1(BN)_"^~"
  1.  S DA=0 FOR  S DA=$O(^TMP("PRCAWR",$J,DA)) Q:'DA  D SETCS^GECSSTAA(GECSFMS("DA"),^(DA))
  1.  D SETCODE^GECSSDCT(GECSFMS("DA"),"D RETN^RCFMFN02")
  1.  D SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
  1.  D SSTAT^RCFMFN02("T"_TN,1)
  1.  W !,"Document Created.  Number # ",GECSFMS("DA"),".",!
  1.  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_" * * * *"
  1.  S $P(^PRCA(430,BN,11),U,22)=FMSNUM
  1.  K ^TMP("PRCAWR",$J)
  1.  Q
  1.  ;