FBNHRCS1 ;ACAMPUS/dmk-RCS 10-0168 CON'T ;10/20/98
;;3.5;FEE BASIS;**12,15**;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
START ;called from FBNHRCS for compiling and printing report
U IO
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
S (I,K)=0,J=""
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
.S FBCN=$P(^FBAA(161.21,K,0),"^") D CONTR K FBCN Q:'$G(FBCSN)
.Q:FBSN'=FBCSN
.S ^TMP($J,"FBRCS",+$P(^FBAA(161.21,K,0),U,4),J,K)=""
;
VAL ;when generating code sheets - validate vendors
I $G(FBGECS) D
. ; loop thru vendors
. S FBV=0 F S FBV=$O(^TMP($J,"FBRCS",FBV)) Q:'FBV D
. . I $P($G(^FBAAV(+FBV,1)),U,6)'?7N D:FBGECS W !,?5,$P($G(^FBAAV(+FBV,0)),U)," (ien: ",+FBV,")"
. . . ; turn off code sheets and print message when 1st problem found
. . . S FBGECS=0
. . . W !!,"WARNING: NO CODE SHEETS WILL BE CREATED"
. . . W !,"The following vendor(s) are missing the required field DATE OF"
. . . W !,"LAST ASSESSMENT. This data must be entered before any code"
. . . W !,"sheets will be created."
. ; if any problems were found then pause screen
. I 'FBGECS,$E(IOST,1,2)="C-" S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR
;
EN ;start going through TMP to output report
; FBV=ien of vendor FBD= latest contract to date(-)
; FBI=ien of latest contract within date range
S FBV=0
F S FBV=$O(^TMP($J,"FBRCS",FBV)) Q:'FBV S FBD=$O(^TMP($J,"FBRCS",FBV,"")),FBI=$O(^(+FBD,0)) D
. ; determine low and high rate
. ; FBLOW=low $ rate FBHIGH=high $ rate
. ; if only one rate (fblow=fbhigh) report FBHIGH only
. S (FBJ,CNT)=0 K FB
. 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)
. N I,J,Z D
.. S (I,J,FBLOW,FBHIGH)=0
.. S FBLOW=$O(FB(0))
.. F S I=$O(FB(I)) Q:'I S FBHIGH=I F S J=$O(FB(I,J)) Q:'J
.. S:FBLOW=FBHIGH FBLOW=0
.. D S ^TMP($J,"FBTOT",FBV)=Z
... S VNAM=$E($$VNAME^FBNHEXP(FBV),1,23) I $L(VNAM)<23 S VNAM=$$LJ^XLFSTR(VNAM,23," ")
... 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")
;
Q
;
CONTR ;get numeric station number fro contract
Q:FBCN']""!($E(FBCN,1)="-")
I $E(FBCN,1,3)?3N S FBCSN=$E(FBCN,1,3) Q
S FBCN=$E(FBCN,2,$L(FBCN)) G CONTR
Q
CSC(X) ; This call will return city(15)_u_state code(2)_u_county(3)
;X= ien from vendor file
N Z S Z=" "
I $S('$G(X):1,'$D(^FBAAV(X,0)):1,1:0) Q Z_U_$E(Z,1,2)_U_$E(Z,1,3)
N C,S,V,Y S V=$G(^FBAAV(X,0))
S Y=$E($P(V,U,4),1,15) I $L(Y)<15 S Y=$$LJ^XLFSTR(Y,15," ")
S S=+$P(V,U,5),S=$P($G(^DIC(5,S,0)),U,3)
S Y=Y_U_S_$E(Z,$L(S)+1,2)_U_$$COUNTY(+$P(V,U,5),+$P(V,U,13))
Q Y
;
COUNTY(X,Y) ;call returns the 3 digit county code
;X= ien of state file
;Y= ien of county in state multiple
;
I $S('X:1,'Y:1,'$D(^DIC(5,X,1,Y,0)):1,1:0) Q " "
Q $S($L($P($G(^DIC(5,X,1,Y,0)),U,3))=3:$P(^(0),U,3),1:" ")
;
DOLLAR(X) ;round off rate to closest dollar and right justify to 3
;X= dollar amount
;
I 'X Q "000"
S X2=0,X3=4
D COMMA^%DTC
Q $E($TR(X," ",0),1,3)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHRCS1 3522 printed Dec 13, 2024@01:59:13 Page 2
FBNHRCS1 ;ACAMPUS/dmk-RCS 10-0168 CON'T ;10/20/98
+1 ;;3.5;FEE BASIS;**12,15**;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
START ;called from FBNHRCS for compiling and printing report
+1 USE IO
+2 DO STATION^FBAAUTL
IF $GET(FBPOP)
WRITE !,"Cannot determine proper station to build code sheets.",!,"Please check your Fee Basis Site Paramaters file (#161.4)"
QUIT
+3 SET (I,K)=0
SET J=""
+4 FOR
SET I=$ORDER(^FBAA(161.21,"ADR",I))
if 'I
QUIT
SET J=""
FOR
SET J=$ORDER(^FBAA(161.21,"ADR",I,J))
if 'J!(J>-FBBEG)
QUIT
SET K=0
FOR
SET K=$ORDER(^FBAA(161.21,"ADR",I,J,K))
if 'K
QUIT
IF $DATA(^FBAA(161.21,K,0))
IF $PIECE(^(0),U,2)'>FBEND
Begin DoDot:1
+5 SET FBCN=$PIECE(^FBAA(161.21,K,0),"^")
DO CONTR
KILL FBCN
if '$GET(FBCSN)
QUIT
+6 if FBSN'=FBCSN
QUIT
+7 SET ^TMP($JOB,"FBRCS",+$PIECE(^FBAA(161.21,K,0),U,4),J,K)=""
End DoDot:1
KILL FBCSN
+8 ;
VAL ;when generating code sheets - validate vendors
+1 IF $GET(FBGECS)
Begin DoDot:1
+2 ; loop thru vendors
+3 SET FBV=0
FOR
SET FBV=$ORDER(^TMP($JOB,"FBRCS",FBV))
if 'FBV
QUIT
Begin DoDot:2
+4 IF $PIECE($GET(^FBAAV(+FBV,1)),U,6)'?7N
if FBGECS
Begin DoDot:3
+5 ; turn off code sheets and print message when 1st problem found
+6 SET FBGECS=0
+7 WRITE !!,"WARNING: NO CODE SHEETS WILL BE CREATED"
+8 WRITE !,"The following vendor(s) are missing the required field DATE OF"
+9 WRITE !,"LAST ASSESSMENT. This data must be entered before any code"
+10 WRITE !,"sheets will be created."
End DoDot:3
WRITE !,?5,$PIECE($GET(^FBAAV(+FBV,0)),U)," (ien: ",+FBV,")"
End DoDot:2
+11 ; if any problems were found then pause screen
+12 IF 'FBGECS
IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
KILL DIR
End DoDot:1
+13 ;
EN ;start going through TMP to output report
+1 ; FBV=ien of vendor FBD= latest contract to date(-)
+2 ; FBI=ien of latest contract within date range
+3 SET FBV=0
+4 FOR
SET FBV=$ORDER(^TMP($JOB,"FBRCS",FBV))
if 'FBV
QUIT
SET FBD=$ORDER(^TMP($JOB,"FBRCS",FBV,""))
SET FBI=$ORDER(^(+FBD,0))
Begin DoDot:1
+5 ; determine low and high rate
+6 ; FBLOW=low $ rate FBHIGH=high $ rate
+7 ; if only one rate (fblow=fbhigh) report FBHIGH only
+8 SET (FBJ,CNT)=0
KILL FB
+9 FOR
SET FBJ=$ORDER(^FBAA(161.22,"AC",FBI,FBJ))
if 'FBJ
QUIT
SET FB(0)=$PIECE($GET(^FBAA(161.22,FBJ,0)),U,2)
IF FB(0)
IF FB(0)<999.99
SET CNT=CNT+1
SET FB(FB(0),CNT)=FB(0)
+10 NEW I,J,Z
Begin DoDot:2
+11 SET (I,J,FBLOW,FBHIGH)=0
+12 SET FBLOW=$ORDER(FB(0))
+13 FOR
SET I=$ORDER(FB(I))
if 'I
QUIT
SET FBHIGH=I
FOR
SET J=$ORDER(FB(I,J))
if 'J
QUIT
+14 if FBLOW=FBHIGH
SET FBLOW=0
+15 Begin DoDot:3
+16 SET VNAM=$EXTRACT($$VNAME^FBNHEXP(FBV),1,23)
IF $LENGTH(VNAM)<23
SET VNAM=$$LJ^XLFSTR(VNAM,23," ")
+17 NEW V
SET V=$GET(^FBAAV(+FBV,1))
SET Z=FBSN_U_VNAM_U_$$CSC(FBV)_U_$PIECE(V,U,8)_U_$PIECE(V,U,4)_U_$$DOLLAR(FBHIGH)_U_$$DOLLAR(FBLOW)_U_$PIECE(V,U,5)_U_$$NVET^FBNHRCS2(FBV,FBEND)_U_$SELECT($PIECE(V,U,6)]"":$EXTRACT($PIECE(V,U,6),1,5)_"00",1:"0000000")
End DoDot:3
SET ^TMP($JOB,"FBTOT",FBV)=Z
End DoDot:2
End DoDot:1
+18 ;
+19 QUIT
+20 ;
CONTR ;get numeric station number fro contract
+1 if FBCN']""!($EXTRACT(FBCN,1)="-")
QUIT
+2 IF $EXTRACT(FBCN,1,3)?3N
SET FBCSN=$EXTRACT(FBCN,1,3)
QUIT
+3 SET FBCN=$EXTRACT(FBCN,2,$LENGTH(FBCN))
GOTO CONTR
+4 QUIT
CSC(X) ; This call will return city(15)_u_state code(2)_u_county(3)
+1 ;X= ien from vendor file
+2 NEW Z
SET Z=" "
+3 IF $SELECT('$GET(X):1,'$DATA(^FBAAV(X,0)):1,1:0)
QUIT Z_U_$EXTRACT(Z,1,2)_U_$EXTRACT(Z,1,3)
+4 NEW C,S,V,Y
SET V=$GET(^FBAAV(X,0))
+5 SET Y=$EXTRACT($PIECE(V,U,4),1,15)
IF $LENGTH(Y)<15
SET Y=$$LJ^XLFSTR(Y,15," ")
+6 SET S=+$PIECE(V,U,5)
SET S=$PIECE($GET(^DIC(5,S,0)),U,3)
+7 SET Y=Y_U_S_$EXTRACT(Z,$LENGTH(S)+1,2)_U_$$COUNTY(+$PIECE(V,U,5),+$PIECE(V,U,13))
+8 QUIT Y
+9 ;
COUNTY(X,Y) ;call returns the 3 digit county code
+1 ;X= ien of state file
+2 ;Y= ien of county in state multiple
+3 ;
+4 IF $SELECT('X:1,'Y:1,'$DATA(^DIC(5,X,1,Y,0)):1,1:0)
QUIT " "
+5 QUIT $SELECT($LENGTH($PIECE($GET(^DIC(5,X,1,Y,0)),U,3))=3:$PIECE(^(0),U,3),1:" ")
+6 ;
DOLLAR(X) ;round off rate to closest dollar and right justify to 3
+1 ;X= dollar amount
+2 ;
+3 IF 'X
QUIT "000"
+4 SET X2=0
SET X3=4
+5 DO COMMA^%DTC
+6 QUIT $EXTRACT($TRANSLATE(X," ",0),1,3)
