FBAAUTL3.m

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 ---FBAAUTL3   2305     printed  Apr 09, 2024@21:03:53                                                                                                                                                                                                    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)