source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBNHRCS1.m@ 1639

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

initial load of WorldVistAEHR
File size: 3.4 KB
Line 
1FBNHRCS1 ;ACAMPUS/dmk-RCS 10-0168 CON'T ;10/20/98
2 ;;3.5;FEE BASIS;**12,15**;JAN 30, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4START ;called from FBNHRCS for compiling and printing report
5 U IO
6 D STATION^FBAAUTL I $G(FBPOP) W !,"Cannot determine proper station to build code sheets.",!,"Please check your Fee Basis Site Paramaters file (#161.4)" Q
7 S (I,K)=0,J=""
8 F S I=$O(^FBAA(161.21,"ADR",I)) Q:'I S J="" F S J=$O(^FBAA(161.21,"ADR",I,J)) Q:'J!(J>-FBBEG) S K=0 F S K=$O(^FBAA(161.21,"ADR",I,J,K)) Q:'K I $D(^FBAA(161.21,K,0)),$P(^(0),U,2)'>FBEND D K FBCSN
9 .S FBCN=$P(^FBAA(161.21,K,0),"^") D CONTR K FBCN Q:'$G(FBCSN)
10 .Q:FBSN'=FBCSN
11 .S ^TMP($J,"FBRCS",+$P(^FBAA(161.21,K,0),U,4),J,K)=""
12 ;
13VAL ;when generating code sheets - validate vendors
14 I $G(FBGECS) D
15 . ; loop thru vendors
16 . S FBV=0 F S FBV=$O(^TMP($J,"FBRCS",FBV)) Q:'FBV D
17 . . I $P($G(^FBAAV(+FBV,1)),U,6)'?7N D:FBGECS W !,?5,$P($G(^FBAAV(+FBV,0)),U)," (ien: ",+FBV,")"
18 . . . ; turn off code sheets and print message when 1st problem found
19 . . . S FBGECS=0
20 . . . W !!,"WARNING: NO CODE SHEETS WILL BE CREATED"
21 . . . W !,"The following vendor(s) are missing the required field DATE OF"
22 . . . W !,"LAST ASSESSMENT. This data must be entered before any code"
23 . . . W !,"sheets will be created."
24 . ; if any problems were found then pause screen
25 . I 'FBGECS,$E(IOST,1,2)="C-" S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR
26 ;
27EN ;start going through TMP to output report
28 ; FBV=ien of vendor FBD= latest contract to date(-)
29 ; FBI=ien of latest contract within date range
30 S FBV=0
31 F S FBV=$O(^TMP($J,"FBRCS",FBV)) Q:'FBV S FBD=$O(^TMP($J,"FBRCS",FBV,"")),FBI=$O(^(+FBD,0)) D
32 . ; determine low and high rate
33 . ; FBLOW=low $ rate FBHIGH=high $ rate
34 . ; if only one rate (fblow=fbhigh) report FBHIGH only
35 . S (FBJ,CNT)=0 K FB
36 . F S FBJ=$O(^FBAA(161.22,"AC",FBI,FBJ)) Q:'FBJ S FB(0)=$P($G(^FBAA(161.22,FBJ,0)),U,2) I FB(0),FB(0)<999.99 S CNT=CNT+1,FB(FB(0),CNT)=FB(0)
37 . N I,J,Z D
38 .. S (I,J,FBLOW,FBHIGH)=0
39 .. S FBLOW=$O(FB(0))
40 .. F S I=$O(FB(I)) Q:'I S FBHIGH=I F S J=$O(FB(I,J)) Q:'J
41 .. S:FBLOW=FBHIGH FBLOW=0
42 .. D S ^TMP($J,"FBTOT",FBV)=Z
43 ... S VNAM=$E($$VNAME^FBNHEXP(FBV),1,23) I $L(VNAM)<23 S VNAM=$$LJ^XLFSTR(VNAM,23," ")
44 ... N V S V=$G(^FBAAV(+FBV,1)) S Z=FBSN_U_VNAM_U_$$CSC(FBV)_U_$P(V,U,8)_U_$P(V,U,4)_U_$$DOLLAR(FBHIGH)_U_$$DOLLAR(FBLOW)_U_$P(V,U,5)_U_$$NVET^FBNHRCS2(FBV,FBEND)_U_$S($P(V,U,6)]"":$E($P(V,U,6),1,5)_"00",1:"0000000")
45 ;
46 Q
47 ;
48CONTR ;get numeric station number fro contract
49 Q:FBCN']""!($E(FBCN,1)="-")
50 I $E(FBCN,1,3)?3N S FBCSN=$E(FBCN,1,3) Q
51 S FBCN=$E(FBCN,2,$L(FBCN)) G CONTR
52 Q
53CSC(X) ; This call will return city(15)_u_state code(2)_u_county(3)
54 ;X= ien from vendor file
55 N Z S Z=" "
56 I $S('$G(X):1,'$D(^FBAAV(X,0)):1,1:0) Q Z_U_$E(Z,1,2)_U_$E(Z,1,3)
57 N C,S,V,Y S V=$G(^FBAAV(X,0))
58 S Y=$E($P(V,U,4),1,15) I $L(Y)<15 S Y=$$LJ^XLFSTR(Y,15," ")
59 S S=+$P(V,U,5),S=$P($G(^DIC(5,S,0)),U,3)
60 S Y=Y_U_S_$E(Z,$L(S)+1,2)_U_$$COUNTY(+$P(V,U,5),+$P(V,U,13))
61 Q Y
62 ;
63COUNTY(X,Y) ;call returns the 3 digit county code
64 ;X= ien of state file
65 ;Y= ien of county in state multiple
66 ;
67 I $S('X:1,'Y:1,'$D(^DIC(5,X,1,Y,0)):1,1:0) Q " "
68 Q $S($L($P($G(^DIC(5,X,1,Y,0)),U,3))=3:$P(^(0),U,3),1:" ")
69 ;
70DOLLAR(X) ;round off rate to closest dollar and right justify to 3
71 ;X= dollar amount
72 ;
73 I 'X Q "000"
74 S X2=0,X3=4
75 D COMMA^%DTC
76 Q $E($TR(X," ",0),1,3)
Note: See TracBrowser for help on using the repository browser.