FBAAUTL3 ;AISC/DMK - FEE BASIS UTILITY ROUTINE ;4/20/2012
;;3.5;FEE BASIS;**132,158**;JAN 30, 1995;Build 94
;;Per VA Directive 6402, this routine should not be modified.
HDR() ;this is a supported call to be used by IFCAP to determine
;the System Identifier for the 994 code sheets
;Q $S($P($G(^FBAA(161.4,1,1)),U,10)]"":$P(^(1),U,10),1:"FEN")
; switch to FEE for the Subsystem Identifier FB*3.5*132
;Q $S($$VER5():"FEN",1:"FEE")
Q "FEN" ;FB*3.5*158
;
POV(X) ;determine ien of pov based on austin code
;INPUT: X = pov code
;OUTPUT: ien of active record containing passed pov code or 0
S:X']"" X=0
Q +$O(^FBAA(161.82,"AC",X,0))
;
RCOMP ;entry point to re-compile templates
S:'$D(DTIME) DTIME=300 S U="^"
S DIR(0)="Y",DIR("A")="Re-compile FB input templates" D ^DIR K DIR G RCOMPQ:'Y
S $P(QQ,"=",81)="" W !!?17,"Recompilation of Fee Basis Input Templates",!,QQ
S FBMAX=^DD("ROU") F FBX="FB VENDOR UPDATE","FBAA AUTHORIZATION" S Y=$O(^DIE("B",FBX,0)) Q:'Y I $D(^DIE(Y,"ROUOLD")),^("ROUOLD")]"",$D(^(0)) S X=$P(^("ROUOLD"),"^"),DMAX=FBMAX D EN^DIEZ
RCOMPQ ;kill off variables and exit re-compile option
K DMAX,FBX,Y,X,QQ,FBMAX
Q
;
UP(X) ;entry point to convert lower case to upper case letters
I $G(X)']"" Q 0
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;
YN ;called from input transform on Yes - No type fields to allow
;a user to enter:
; 1 = Yes 0 = No stores Y or N
;
S X=$E($$UP^FBAAUTL3(X))
S X=$S(X:"Y",X="Y":X,X="N":X,X=0:"N",1:2)
I X'=2 W " (",$S(X="Y":"YES",1:"NO"),")" Q
W *7,!?4,"NOT A VALID ENTRY!" K X
Q
;
OUTYN ;called from output transform on fields that are defined as Y/N
;
S Y=$S(Y="Y":"YES",Y="N":"NO",1:"")
Q
;
VER5() ;returns '1' if site is running version 5 of IFCAP
;used to handle record layouts for FMS payments
N X
;S X=$G(^DIC(9.4,+$O(^DIC(9.4,"C","PRC",0)),"VERSION"))
S X=$$VERSION^XPDUTL("PRC")
Q $S(+X>4:1,1:0)
;
IDCHK(DFN,AUTH) ;call to check if authorization being paid is
;an ID card. Called during payment process.
;DFN = patients internal entry number
;AUTH= internal entry number of authorization in 161.
;both are required
I $S('$G(DFN):1,'$G(AUTH):1,1:0) Q 0
Q $S('$D(^FBAAA(+DFN,1,+AUTH,0)):0,$P(^(0),U,13)=3:1,1:0)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAUTL3 2305 printed Oct 16, 2024@17:57:38 Page 2
FBAAUTL3 ;AISC/DMK - FEE BASIS UTILITY ROUTINE ;4/20/2012
+1 ;;3.5;FEE BASIS;**132,158**;JAN 30, 1995;Build 94
+2 ;;Per VA Directive 6402, this routine should not be modified.
HDR() ;this is a supported call to be used by IFCAP to determine
+1 ;the System Identifier for the 994 code sheets
+2 ;Q $S($P($G(^FBAA(161.4,1,1)),U,10)]"":$P(^(1),U,10),1:"FEN")
+3 ; switch to FEE for the Subsystem Identifier FB*3.5*132
+4 ;Q $S($$VER5():"FEN",1:"FEE")
+5 ;FB*3.5*158
QUIT "FEN"
+6 ;
POV(X) ;determine ien of pov based on austin code
+1 ;INPUT: X = pov code
+2 ;OUTPUT: ien of active record containing passed pov code or 0
+3 if X']""
SET X=0
+4 QUIT +$ORDER(^FBAA(161.82,"AC",X,0))
+5 ;
RCOMP ;entry point to re-compile templates
+1 if '$DATA(DTIME)
SET DTIME=300
SET U="^"
+2 SET DIR(0)="Y"
SET DIR("A")="Re-compile FB input templates"
DO ^DIR
KILL DIR
if 'Y
GOTO RCOMPQ
+3 SET $PIECE(QQ,"=",81)=""
WRITE !!?17,"Recompilation of Fee Basis Input Templates",!,QQ
+4 SET FBMAX=^DD("ROU")
FOR FBX="FB VENDOR UPDATE","FBAA AUTHORIZATION"
SET Y=$ORDER(^DIE("B",FBX,0))
if 'Y
QUIT
IF $DATA(^DIE(Y,"ROUOLD"))
IF ^("ROUOLD")]""
IF $DATA(^(0))
SET X=$PIECE(^("ROUOLD"),"^")
SET DMAX=FBMAX
DO EN^DIEZ
RCOMPQ ;kill off variables and exit re-compile option
+1 KILL DMAX,FBX,Y,X,QQ,FBMAX
+2 QUIT
+3 ;
UP(X) ;entry point to convert lower case to upper case letters
+1 IF $GET(X)']""
QUIT 0
+2 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+3 ;
YN ;called from input transform on Yes - No type fields to allow
+1 ;a user to enter:
+2 ; 1 = Yes 0 = No stores Y or N
+3 ;
+4 SET X=$EXTRACT($$UP^FBAAUTL3(X))
+5 SET X=$SELECT(X:"Y",X="Y":X,X="N":X,X=0:"N",1:2)
+6 IF X'=2
WRITE " (",$SELECT(X="Y":"YES",1:"NO"),")"
QUIT
+7 WRITE *7,!?4,"NOT A VALID ENTRY!"
KILL X
+8 QUIT
+9 ;
OUTYN ;called from output transform on fields that are defined as Y/N
+1 ;
+2 SET Y=$SELECT(Y="Y":"YES",Y="N":"NO",1:"")
+3 QUIT
+4 ;
VER5() ;returns '1' if site is running version 5 of IFCAP
+1 ;used to handle record layouts for FMS payments
+2 NEW X
+3 ;S X=$G(^DIC(9.4,+$O(^DIC(9.4,"C","PRC",0)),"VERSION"))
+4 SET X=$$VERSION^XPDUTL("PRC")
+5 QUIT $SELECT(+X>4:1,1:0)
+6 ;
IDCHK(DFN,AUTH) ;call to check if authorization being paid is
+1 ;an ID card. Called during payment process.
+2 ;DFN = patients internal entry number
+3 ;AUTH= internal entry number of authorization in 161.
+4 ;both are required
+5 IF $SELECT('$GET(DFN):1,'$GET(AUTH):1,1:0)
QUIT 0
+6 QUIT $SELECT('$DATA(^FBAAA(+DFN,1,+AUTH,0)):0,$PIECE(^(0),U,13)=3:1,1:0)
