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

FBNHRCS1.m

Go to the documentation of this file.
  1. FBNHRCS1 ;ACAMPUS/dmk-RCS 10-0168 CON'T ;10/20/98
  1. ;;3.5;FEE BASIS;**12,15**;JAN 30, 1995
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. START ;called from FBNHRCS for compiling and printing report
  1. U IO
  1. 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
  1. S (I,K)=0,J=""
  1. 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
  1. .S FBCN=$P(^FBAA(161.21,K,0),"^") D CONTR K FBCN Q:'$G(FBCSN)
  1. .Q:FBSN'=FBCSN
  1. .S ^TMP($J,"FBRCS",+$P(^FBAA(161.21,K,0),U,4),J,K)=""
  1. ;
  1. VAL ;when generating code sheets - validate vendors
  1. I $G(FBGECS) D
  1. . ; loop thru vendors
  1. . S FBV=0 F S FBV=$O(^TMP($J,"FBRCS",FBV)) Q:'FBV D
  1. . . I $P($G(^FBAAV(+FBV,1)),U,6)'?7N D:FBGECS W !,?5,$P($G(^FBAAV(+FBV,0)),U)," (ien: ",+FBV,")"
  1. . . . ; turn off code sheets and print message when 1st problem found
  1. . . . S FBGECS=0
  1. . . . W !!,"WARNING: NO CODE SHEETS WILL BE CREATED"
  1. . . . W !,"The following vendor(s) are missing the required field DATE OF"
  1. . . . W !,"LAST ASSESSMENT. This data must be entered before any code"
  1. . . . W !,"sheets will be created."
  1. . ; if any problems were found then pause screen
  1. . I 'FBGECS,$E(IOST,1,2)="C-" S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR
  1. ;
  1. EN ;start going through TMP to output report
  1. ; FBV=ien of vendor FBD= latest contract to date(-)
  1. ; FBI=ien of latest contract within date range
  1. S FBV=0
  1. F S FBV=$O(^TMP($J,"FBRCS",FBV)) Q:'FBV S FBD=$O(^TMP($J,"FBRCS",FBV,"")),FBI=$O(^(+FBD,0)) D
  1. . ; determine low and high rate
  1. . ; FBLOW=low $ rate FBHIGH=high $ rate
  1. . ; if only one rate (fblow=fbhigh) report FBHIGH only
  1. . S (FBJ,CNT)=0 K FB
  1. . 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)
  1. . N I,J,Z D
  1. .. S (I,J,FBLOW,FBHIGH)=0
  1. .. S FBLOW=$O(FB(0))
  1. .. F S I=$O(FB(I)) Q:'I S FBHIGH=I F S J=$O(FB(I,J)) Q:'J
  1. .. S:FBLOW=FBHIGH FBLOW=0
  1. .. D S ^TMP($J,"FBTOT",FBV)=Z
  1. ... S VNAM=$E($$VNAME^FBNHEXP(FBV),1,23) I $L(VNAM)<23 S VNAM=$$LJ^XLFSTR(VNAM,23," ")
  1. ... 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")
  1. ;
  1. Q
  1. ;
  1. CONTR ;get numeric station number fro contract
  1. Q:FBCN']""!($E(FBCN,1)="-")
  1. I $E(FBCN,1,3)?3N S FBCSN=$E(FBCN,1,3) Q
  1. S FBCN=$E(FBCN,2,$L(FBCN)) G CONTR
  1. Q
  1. CSC(X) ; This call will return city(15)_u_state code(2)_u_county(3)
  1. ;X= ien from vendor file
  1. N Z S Z=" "
  1. I $S('$G(X):1,'$D(^FBAAV(X,0)):1,1:0) Q Z_U_$E(Z,1,2)_U_$E(Z,1,3)
  1. N C,S,V,Y S V=$G(^FBAAV(X,0))
  1. S Y=$E($P(V,U,4),1,15) I $L(Y)<15 S Y=$$LJ^XLFSTR(Y,15," ")
  1. S S=+$P(V,U,5),S=$P($G(^DIC(5,S,0)),U,3)
  1. S Y=Y_U_S_$E(Z,$L(S)+1,2)_U_$$COUNTY(+$P(V,U,5),+$P(V,U,13))
  1. Q Y
  1. ;
  1. COUNTY(X,Y) ;call returns the 3 digit county code
  1. ;X= ien of state file
  1. ;Y= ien of county in state multiple
  1. ;
  1. I $S('X:1,'Y:1,'$D(^DIC(5,X,1,Y,0)):1,1:0) Q " "
  1. Q $S($L($P($G(^DIC(5,X,1,Y,0)),U,3))=3:$P(^(0),U,3),1:" ")
  1. ;
  1. DOLLAR(X) ;round off rate to closest dollar and right justify to 3
  1. ;X= dollar amount
  1. ;
  1. I 'X Q "000"
  1. S X2=0,X3=4
  1. D COMMA^%DTC
  1. Q $E($TR(X," ",0),1,3)