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