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

FBUCLET1.m

Go to the documentation of this file.
  1. FBUCLET1 ;ALBISC/TET - UNAUTHORIZED CLAIM LETTER (continued) ;29/NOV/2006
  1. ;;3.5;FEE BASIS;**12,23,32,38,101**;JAN 30, 1995;Build 2
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. PRINT ;print letter, don't update if variable fbnoup exists
  1. ;INPUT: FBDA = ien of unauthorized claim, file 162.7
  1. ; FBORDER = (optional) order number of status
  1. ; FBUCA = current (after) zero node of unauthorized claim (162.7)
  1. ; FBUC = unauthorized claim node in parameter file
  1. ; FBNOUP = 1 if no update is to occur, optional, set in reprint
  1. ; FBFF = counter flag, suppresses formfeed if = 0
  1. ; FBCOPIES = # of copies to print, optional, not set from auto
  1. ; FBSTANUM = station number
  1. ; FBSADD( array = station address, if site parameter designates letterhead not used
  1. ;VAR FBADD( = address array to where letter is mailed
  1. ; FBADDCC( = address array for carbon copy
  1. ; FBCC = flag, true if CC address should print at bottom of page
  1. ; FBCCI = # used to determine where CC address prints
  1. ; FBTAMT = $ amount calculated in routine FBUCLET2 for an
  1. ; approved or approved to stabilization disposition
  1. ; letter. Used to populate field #14 in file #162.7.
  1. ;OUTPUT: none - print letter and update fields, if '$d(fbnoup), upon completion
  1. N FBADD,FBADDCC,FBAUTH,FBC,FBEP,FBLETDT,FBLIEN,FBMCODE,FBNAM,FBNAM1
  1. N FBPROG,FBRE,FBSUBMIT,FBTAMT,FBCC,FBCCI
  1. S FBLETDT=0 S:FBORDER']"" FBORDER=$$ORDER^FBUCUTL(FBDA) S ZTSTOP=$$S^%ZTLOAD
  1. D ADDRESS^FBUCUTL2(FBUCA)
  1. S FBSUBMIT=$P(FBUCA,U,23),FBPROG=$$PROG^FBUCUTL(+$P(FBUCA,U,2))
  1. S FBNAM=$S(FBSUBMIT["FBAAV("!(FBSUBMIT["VA(200,"):$$VET^FBUCUTL(+$P(FBUCA,U,4)),1:$$VEN^FBUCUTL(+$P(FBUCA,U,3))) I FBNAM["," S FBNAM=$P(FBNAM,",",2)_" "_$P(FBNAM,",")
  1. I FBSUBMIT'["DPT(" S FBNAM1=$$VEN^FBUCUTL(+$P(FBUCA,U,3)) I FBNAM1["," S FBNAM1=$P(FBNAM1,",",2)_" "_$P(FBNAM1,",")
  1. ;
  1. ; Utilize new API for Name Standardization
  1. ;
  1. I FBNAM'="UNKNOWN",FBSUBMIT["FBAAV("!(FBSUBMIT["VA(200,") D
  1. .S FBNAM=$$GETNAME(+$P(FBUCA,U,4),2,"G","")
  1. .Q
  1. ;
  1. S FBRE=$S(FBSUBMIT']""!(FBSUBMIT["DPT("):"VENDOR:",1:"VETERAN:")
  1. S FBEP=$$FMTE^XLFDT(+$P(FBUCA,U,5)) S:$P(FBUCA,U,6)'=$P(FBUCA,U,5) FBEP=FBEP_"^"_$$FMTE^XLFDT(+$P(FBUCA,U,6))
  1. S FBAUTH=$$FMTE^XLFDT(+$P(FBUCA,U,13)) S:$P(FBUCA,U,14)'=$P(FBUCA,U,13) FBAUTH=FBAUTH_"^"_$$FMTE^XLFDT(+$P(FBUCA,U,14))
  1. S FBLIEN=$$LETTER^FBUCUTL2(FBORDER,+$P(FBUCA,U,28))
  1. S FBMCODE=$$GET1^DIQ(161.4,1,5.5) ; Load Mail Code
  1. I '$D(FBCOPIES) S FBCOPIES=$S($P(FBUC,U,4):$P(FBUC,U,4),1:1)
  1. I FBLIEN F FBC=1:1:FBCOPIES D
  1. .N DIWF,DIWL,FBEXP,FBI,FBDL1
  1. .;set flag true when disposition letter to indicate that a CC address
  1. .;needs to be printed at the bottom of the first page
  1. .S FBCC=$S(FBORDER>20:1,1:0)
  1. .;set FBCCI = blank lines before address (2) + max address lines (5) +
  1. .; # of lines after address from site parameters + a constant (2)
  1. .;S FBCCI=2+5+$S($P(FBUC,U,10)]"":$P(FBUC,U,10),1:9)+2 ; default param
  1. .S FBCCI=2+5+$P(FBUC,U,10)+2
  1. .S FBFF=FBFF+1 W:FBFF&(FBFF>1) @IOF W !
  1. .W:$P(FBUC,U,8) !!!!! D:'$P(FBUC,U,8)
  1. ..N FBI,FBX,FBCT S (FBCT,FBI)=0 F S FBI=$O(FBSADD(FBI)) Q:'FBI S FBX=FBSADD(FBI) W !?(IOM-$L(FBX)/2),FBX S FBCT=FBCT+1
  1. ..S FBCT=5-FBCT I FBCT>0 F FBI=1:1:FBCT W ! ;ensure length of header is consistant
  1. .W !?4,$$PDATE^FBUCUTL2(DT),!
  1. .W:'$P(FBUC,U,8) ?47,"In Reply Refer To: " W ?66,FBSTANUM,"/",FBMCODE
  1. .W !?50,$$GETNAME(+$P(FBUCA,U,4),2,"F","C")
  1. .S (FBCT,FBI)=0 F S FBI=$O(FBADD(FBI)) Q:'FBI W !?4,FBADD(FBI) S FBCT=FBCT+1 I FBI=1 W ?50,$$SSNL4^FBAAUTL($$SSN^FBAAUTL(+$P(FBUCA,U,4)))
  1. .D HED
  1. .S DIWF="WC79I4",DIWL=1 D:$Y+$S(FBCCI>10&FBCC:FBCCI,1:10)>IOSL PAGE D TXT^FBUCUTL2("^FBAA(161.3,",FBLIEN,1,DIWF,DIWL,1,.FBCC,FBCCI) W !
  1. .S DIWF="WC72I8",DIWL=1
  1. .I FBORDER>20 D:$Y+$S(FBCCI>10&FBCC:FBCCI,1:10)>IOSL PAGE D TXT^FBUCUTL2("^FB(162.91,",+$P(FBUCA,U,11),$S(+$P(FBUCA,U,28):2,1:1),DIWF,DIWL,1,.FBCC,FBCCI) D
  1. ..; if approved (or approved to stabilization) then include details
  1. ..I $P(FBUCA,U,11)=1!($P(FBUCA,U,11)=4) D AUTHPR^FBUCLET2
  1. ..I +$P(FBUCA,U,11)'=1,+$O(^FB583(FBDA,"D",0)) D:$Y+$S(FBCCI>10&FBCC:FBCCI,1:10)>IOSL PAGE W !?8,"Reason(s) for not approving "_$S($P(FBUCA,U,11)=4:"entire ",1:"")_"claim:" D
  1. ...N DIWF,FBI,FBZ S DIWF="WC69I8",FBI=0 F S FBI=$O(^FB583(FBDA,"D",FBI)) Q:'FBI S FBZ=^(FBI,0) D:$Y+$S(FBCCI>8&FBCC:FBCCI,1:8)>IOSL PAGE W ! D TXT^FBUCUTL2("^FB(162.94,",+FBZ,1,DIWF,DIWL,1,.FBCC,FBCCI)
  1. ..;
  1. ..;print optional disposition remarks for the claim
  1. ..I FBORDER>20 D
  1. ...N DIWF,DIWL,FBN
  1. ...; select appropriate wp field based on status (appeal, cova, initial)
  1. ...S FBN=$S(FBORDER=70:"""A1""",FBORDER=90:"""A2""",1:4)
  1. ...Q:'$O(^FB583(FBDA,FBN,0)) ; no remarks on file
  1. ...D:$Y+$S(FBCCI>7&FBCC:FBCCI,1:7)>IOSL PAGE
  1. ...W !
  1. ...S DIWF="WC72I8",DIWL=1
  1. ...D TXT^FBUCUTL2("^FB583(",FBDA,FBN,DIWF,DIWL,1,.FBCC,FBCCI)
  1. ..;
  1. ..;print additional description text (if any) for disposition
  1. ..I $O(^FB(162.91,+$P(FBUCA,U,11),3,0)) D
  1. ...N DIWF,DIWL
  1. ...D:$Y+$S(FBCCI>10&FBCC:FBCCI,1:10)>IOSL PAGE
  1. ...W !
  1. ...S DIWF="WC72I8",DIWL=1
  1. ...D TXT^FBUCUTL2("^FB(162.91,",+$P(FBUCA,U,11),3,DIWF,DIWL,1,.FBCC,FBCCI)
  1. .I FBORDER'>20 S FBI=0 F S FBI=$O(^FBAA(162.8,"AC",FBDA,FBI)) Q:'FBI S FBZ=$G(^FBAA(162.8,FBI,0)) I '$P(FBZ,U,5) D:$Y+$S(FBCCI>12&FBCC:FBCCI,1:12)>IOSL PAGE D
  1. ..N FBX W ! S FBX=$P($G(^FB(162.93,+$P(FBZ,U,3),0)),U) I FBX="OTHER" S:$P(FBZ,U,4)]"" FBX=$P(FBZ,U,4) W ?8,FBX,! Q
  1. ..D TXT^FBUCUTL2("^FB(162.93,",+$P(FBZ,U,3),1,DIWF,DIWL,1,.FBCC,FBCCI)
  1. .S DIWF="WC79I4",DIWL=1 D:($Y+4+$S(FBCCI>$S(FBORDER>20:15,1:22)&FBCC:FBCCI,FBORDER>20:15,1:22))>IOSL PAGE W ! D TXT^FBUCUTL2("^FBAA(161.3,",FBLIEN,2,DIWF,DIWL,1,.FBCC,FBCCI)
  1. .;print postscript (if any) on request info. letter
  1. .I FBORDER'>20 S FBI=0 F S FBI=$O(^FBAA(162.8,"AC",FBDA,FBI)) Q:'FBI S FBZ=$G(^FBAA(162.8,FBI,0)) I '$P(FBZ,U,5) D
  1. ..N FBX,FBPS
  1. ..Q:'$O(^FB(162.93,+$P(FBZ,U,3),2,0)) ; no postscript to print
  1. ..;start new page
  1. ..S FBPS=1 D PAGE S FBPS=0
  1. ..W !!
  1. ..;print text
  1. ..S FBX=$P($G(^FB(162.93,+$P(FBZ,U,3),0)),U)
  1. ..I FBX="SIGNED STATEMENT FROM CLAIMANT",$P(FBZ,U,4)]"",$E($P(FBZ,U,4),1)=0 D
  1. ...; just print statement since user specified that regulations should
  1. ...; not be printed (stop after line 11 of postscript)
  1. ...N FBI,FBTXT
  1. ...S FBI=0 F S FBI=$O(^FB(162.93,+$P(FBZ,U,3),2,FBI)) Q:FBI>11!'FBI D
  1. ....S FBTXT=^FB(162.93,+$P(FBZ,U,3),2,FBI,0),X=FBTXT
  1. ....I $Y+$S(FBCCI>7&FBCC:FBCCI,1:7)>IOSL D PAGE
  1. ....D ^DIWP
  1. ...I $Y+$S(FBCCI>7&FBCC:FBCCI,1:7)>IOSL D PAGE
  1. ...D:$D(FBTXT) ^DIWW
  1. ..E D TXT^FBUCUTL2("^FB(162.93,",+$P(FBZ,U,3),2,DIWF,DIWL,1,.FBCC,FBCCI) ;entire ps
  1. .;if still on 1st page of disposition letter then print the CC address
  1. .I FBCC D CCADDR
  1. ;
  1. I '$D(FBNOUP) D
  1. .D:$D(XRTL) T0^%ZOSV ;start monitor
  1. .S FBEXP=$$EXPIRE^FBUCUTL8(FBDA,DT,FBUCA,FBORDER)
  1. .D EDITL^FBUCED(FBDA,FBEXP,"@",DT,$G(FBTAMT))
  1. .S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV ;stop monitor
  1. Q
  1. ;
  1. GETNAME(FBIEN,FBFILE,FBFMT,FBFLAG) ;
  1. N FBNAMES
  1. I FBIEN=""!(FBFILE)="" Q "" ; Quit if there is no IEN or File number
  1. S FBFMT=$G(FBFMT),FBFLAG=$G(FBFLAG)
  1. S FBNAMES("FILE")=FBFILE,FBNAMES("IENS")=FBIEN,FBNAMES("FIELD")=.01
  1. S FBNAMES=$$NAMEFMT^XLFNAME(.FBNAMES,FBFMT,FBFLAG)
  1. Q FBNAMES
  1. ;
  1. PAGE ;new page
  1. ;print CC address at bottom of 1st page on disposition letters
  1. I FBCC D CCADDR
  1. W @IOF,!!!!!!!
  1. ; if called from 1st page of postscript print then include more info
  1. I $G(FBPS)=1 D
  1. .W:'$P(FBUC,U,8) ?47,"In Reply Refer To: " W ?66,FBSTANUM,"/",FBMCODE
  1. .W !?50,$$GETNAME(+$P(FBUCA,U,4),2,"F","C")
  1. .W !?50,$$SSNL4^FBAAUTL($$SSN^FBAAUTL(+$P(FBUCA,U,4)))
  1. HED ;header to print after address and on each new page
  1. W !!!!?8,"REGARDING:",?20,FBRE,?38,FBNAM I $D(FBNAM1) W !?20,"VENDOR:",?38,FBNAM1
  1. W !?20,"FEE PROGRAM:",?38,FBPROG
  1. W !?20,"EPISODE OF CARE:",?38,$P(FBEP,U) W:$P(FBEP,U,2)]"" " to ",$P(FBEP,U,2)
  1. W !!
  1. Q
  1. CCADDR ; print CC address at bottom of page
  1. ; advance to bottom of page
  1. N FBI
  1. F FBI=$Y+FBCCI-1:1:$S(IOSL>120:$Y+FBCCI,1:IOSL) W !
  1. ; print CC address lines
  1. S FBI=0
  1. F S FBI=$O(FBADDCC(FBI)) Q:'FBI W ! W:FBI=1 " CC:" W ?4,FBADDCC(FBI)
  1. ;set flag to false since CC address has been printed
  1. S FBCC=0
  1. Q