- 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 Feb 18, 2025@23:25:38 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)