source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBUCUTL2.m@ 1150

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

initial load of WorldVistAEHR
File size: 6.5 KB
Line 
1FBUCUTL2 ;ALBISC/TET - UTILITY (CONTINUED) ;2/12/2003
2 ;;3.5;FEE BASIS;**23,32,38,52**;JAN 30, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5ADDRESS(FBUCA) ;set up address (FBADD) and carbon copy address (FBADDCC)
6 ;INPUT: FBUCA = current (or after) zero node for UC (file #162.7)
7 ;OUTPUT: FBADD( array, subscripted by sequential number; FBADD = count
8 ; FBADDCC( array, subscripted by sequential number; FBADDCC=count
9 N FBDA,FBGL,FBSUB
10 K FBADD,FBADDCC
11 S FBSUB=$P(FBUCA,U,23)
12 S:FBSUB']"" FBSUB=$P(FBUCA,U,4)_";DPT("
13 S FBDA=+$P(FBSUB,";")
14 I FBSUB["FBAAV" D VENADD(FBDA,.FBADD) D VETADD($P(FBUCA,U,4),.FBADDCC)
15 I FBSUB["DPT" D VETADD(FBDA,.FBADD) D VENADD($P(FBUCA,U,3),.FBADDCC)
16 I FBSUB["VA(200" D OTHADD(FBDA,.FBADD) D VETADD($P(FBUCA,U,4),.FBADDCC)
17 Q
18VETADD(DFN,FBARR) ;set up veteran address
19 ;INPUT: DFN = veteran ien
20 ; FBARR array that will hold the address (passed by reference)
21 ;VAPA("CD") - date for ADD^VADPT if not defined then NOW will be used
22 ; VAPA will be killed!
23 ;
24 ;OUTPUT FBARR array will contain the veteran mailing address,
25 ; subscripted by sequential number; FBARR = line count
26 N FBCT,FBI
27 K FBARR
28 S FBCT=0
29 I $G(DFN)>0 D
30 .S FBCT=FBCT+1,FBARR(FBCT)=$$GETNAME^FBUCLET1(DFN,2,"G")
31 .D ADD^VADPT I 'VAERR D K VAPA,VAERR
32 . . I $$ACTIVECC^FBAACO0() D Q
33 . . . F FBI=13,14,15 S:$G(VAPA(FBI))]"" FBCT=FBCT+1,FBARR(FBCT)=$G(VAPA(FBI))
34 . . . S FBCT=FBCT+1,FBARR(FBCT)=$S($G(VAPA(16))]"":$G(VAPA(16)),1:" ")_" "_$S($P($G(VAPA(17)),U,2)]"":$P($G(VAPA(17)),U,2),1:" ")_" "_$P($G(VAPA(18)),U,2)
35 ..F FBI=1,2,3 S:VAPA(FBI)]"" FBCT=FBCT+1,FBARR(FBCT)=VAPA(FBI)
36 ..S FBCT=FBCT+1,FBARR(FBCT)=$S(VAPA(4)]"":VAPA(4),1:" ")_" "_$S($P(VAPA(5),U,2)]"":$P(VAPA(5),U,2),1:" ")_" "_$S('+$G(VAPA(11)):VAPA(6),$P(VAPA(11),U,2)]"":$P(VAPA(11),U,2),1:VAPA(6))
37 S FBARR=FBCT
38 Q
39 ;
40VENADD(FBV,FBARR) ;set up vendor address
41 ;INPUT: FBV = vendor ien (file 161.2)
42 ; FBARR array that will hold the address (passed by reference)
43 ;OUTPUT FBARR array will contain the vendor mailing address,
44 ; subscripted by sequential number; FBARR = line count
45 N FBCT,FBP,FBSTATE,FBZ
46 K FBARR
47 S FBCT=0
48 I $G(FBV)>0 D
49 .S FBZ=$G(^FBAAV(FBV,0))
50 .S FBCT=FBCT+1,FBARR(FBCT)=$P(FBZ,U)
51 .I FBARR(1)["," S FBARR(1)=$P(FBARR(1),",",2)_" "_$P(FBARR(1),",")
52 .S FBSTATE=$P($G(^DIC(5,+$P(FBZ,U,5),0)),U,2)
53 .F FBP=3,14 S:$P(FBZ,U,FBP)]"" FBCT=FBCT+1,FBARR(FBCT)=$P(FBZ,U,FBP)
54 .S FBCT=FBCT+1,FBARR(FBCT)=$S($P(FBZ,U,4)]"":$P(FBZ,U,4),1:" ")_" "_$S(FBSTATE]"":FBSTATE,1:" ")_" "_$P(FBZ,U,6)
55 S FBARR=FBCT
56 Q
57OTHADD(FBDA,FBARR) ;set up other party address
58 ;INPUT: FBDA = other party ien (file 200)
59 ; FBARR array that will hold the address (passed by reference)
60 ;OUTPUT FBARR array will contain the vendor mailing address,
61 ; subscripted by sequential number; FBARR = line count
62 N FBCT,FBP,FBSTATE,FBZ11
63 K FBARR
64 S FBCT=0
65 I $G(FBDA)>0 D
66 .S FBCT=FBCT+1,FBARR(FBCT)=$$GETNAME^FBUCLET1(FBDA,200,"G")
67 .S FBZ11=$G(^VA(200,FBDA,.11))
68 .I FBZ11]"" D
69 ..S FBSTATE=$P($G(^DIC(5,+$P(FBZ11,U,5),0)),U,2)
70 ..F FBP=1,2,3 S:$P(FBZ11,U,FBP)]"" FBCT=FBCT+1,FBARR(FBCT)=$P(FBZ11,U,FBP)
71 ..S FBCT=FBCT+1,FBARR(FBCT)=$S($P(FBZ11,U,4)]"":$P(FBZ11,U,4),1:" ")_" "_$S(FBSTATE]"":FBSTATE,1:" ")_" "_$P(FBZ11,U,6)
72 S FBARR=FBCT
73 Q
74STATADD ;station address, from fee basis site parameter file
75 ;INPUT: nothing
76 ;OUTPUT: FBSADD( array of station name,address, and number
77 ;called when printing a letter, used if letterhead not used
78 K ^UTILITY("DIQ1",$J) N DIC,DA,DIQ,DR,FBCT,FBP S DIC="^FBAA(161.4,",DA=1,DIQ="FBSADD(" D
79 .S DR="1:2;16",DIQ(0)="EN" D EN^DIQ1
80 .S DR="3:5;35.6",DIQ(0)="E" D EN^DIQ1
81 .;S DR=27,DIQ(0)="IN" D EN^DIQ1
82 I $G(FBSADD(161.4,1,16,"E"))]"" S FBSADD(161.4,1,2.5,"E")=FBSADD(161.4,1,16,"E") K FBSADD(161.4,1,16,"E") ;set street address lines together
83 S FBSADD(161.4,1,.01,"E")=$G(FBSADD(161.4,1,35.6,"E")) K FBSADD(161.4,1,35.6,"E") ;re-set so name is first
84 S (FBCT,FBP)=0 F S FBP=$O(FBSADD(161.4,1,FBP)) Q:FBP'<3!('FBP) S:$G(FBSADD(161.4,1,FBP,"E"))]"" FBCT=FBCT+1,FBSADD(FBCT)=FBSADD(161.4,1,FBP,"E") K FBSADD(161.4,1,FBP)
85 S FBCT=FBCT+1,FBSADD(FBCT)=$S($G(FBSADD(161.4,1,3,"E"))]"":FBSADD(161.4,1,3,"E"),1:" ")_" "_$S($G(FBSADD(161.4,1,4,"E"))]"":FBSADD(161.4,1,4,"E"),1:" ")_" "_$G(FBSADD(161.4,1,5,"E")) F FBP=3:1:5 K FBSADD(161.4,1,FBP)
86 K ^UTILITY("DIQ1",$J) Q
87STANUM ;get station number
88 ;INPUT: nothing
89 ;OUTPUT: FBSTANUM = station number of PSA, as set in FB site parameter
90 K ^UTILITY("DIQ1",$J) N DA,DIC,DIQ,DR S DA=1,DIC="^FBAA(161.4,",DIQ="FBSTA(",DR=27,DIQ(0)="IN" D EN^DIQ1 K ^UTILITY("DIQ1",$J)
91 S FBSTANUM=$G(FBSTA(161.4,1,27,"I")) I FBSTANUM]"" S FBSTANUM=$P($G(^DIC(4,FBSTANUM,99)),U)
92 K FBSTA(161.4) Q
93LETTER(FBORDER,FB1725) ;get letter ien number
94 ;INPUT: FBORDER = order number of status
95 ; FB1725 = (optional) =true to select a 38 U.S.C. 1725 letter
96 ;OUTPUT: ien of letter or 0
97 N Y,PIECE
98 S Y=+$O(^FB(162.92,"AO",FBORDER,0))
99 S PIECE=$S($G(FB1725):6,1:5)
100 Q +$P($G(^FB(162.92,Y,0)),"^",PIECE)
101 ;
102TXT(FBGL,FBIEN,FBN,DIWF,DIWL,FBLET,FBCC,FBCCI,FBLBL) ;write txt
103 ;INPUT: FBGL = global root
104 ; FBIEN = internal entry number of file
105 ; FBN = node where wp info resides
106 ; DIWF = format
107 ; DIWL = left offset
108 ; FBLET = 1 if coming from letter (optional)
109 ; FBCC = 1 if CC address will print at bottom of page (optional)
110 ; passed by reference
111 ; FBCCI = number lines needed for CC address (required if FBCC=1)
112 ; FBLBL = label text to print at beginning of 1st line (optional)
113 N FBI,FBNODE,FBTXT,X S FBNODE=FBGL_FBIEN_","_FBN S FBLET=$S('$D(FBLET):0,1:+FBLET)
114 I $D(@(FBNODE_")")) S X=$G(FBLBL) D:X]"" ^DIWP S FBI=0 F S FBI=$O(@(FBNODE_","_FBI_")")) Q:'FBI S FBTXT=^(FBI,0),X=FBTXT D
115 .I $Y+$S($G(FBCCI)>7&$G(FBCC):FBCCI,1:7)>IOSL W:'FBLET @IOF D:FBLET PAGE^FBUCLET1
116 .D ^DIWP
117 I $Y+$S($G(FBCCI)>7&$G(FBCC):FBCCI,1:7)>IOSL W:'FBLET @IOF D:FBLET PAGE^FBUCLET1
118 D:$D(FBTXT) ^DIWW
119 K FBLET Q
120PAGE ;write page
121 W @IOF Q
122PDATE(FBDT) ;output fcn of date, long form
123 ;INPUT: FBDT = date for output
124 ;OUTPUT: month day, year
125 N FBPDT,Y S Y=FBDT D PDATE^FBAAUTL Q $G(FBPDT)
126 ;
127FBUC(X) ;unauthorized claim parameters
128 ;INPUT: X = ien of parameter
129 ;OUTPUT: "UC" node in parameter file
130 Q $G(^FBAA(161.4,X,"UC"))
131 ;
132DIE(DIE,DA,DR) ;update a field
133 ;INPUT: DIE = global root
134 ; DA = record to be updated
135 ; DR = field to be updated
136 ;OUTPUT: update record in file
137 I $S($G(DIE)']"":1,$G(DR)']"":1,'+$G(DA):1,1:0) Q
138 N FBLOCK
139 D LOCK^FBUCUTL(DIE,DA,1) I FBLOCK D ^DIE L -@(DIE_DA_")") K FBLOCK
140 Q
Note: See TracBrowser for help on using the repository browser.