FBAAUTL5 ;ACAMPUS/DMK-UTILITY ROUTINE ;4/17/2000
;;3.5;FEE BASIS;**3,4,21**;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
INPUT ;called from input transform of 163.99 to determine if CPT and
;or modifier is a valid entry in appropriate file.
Q:'$D(X)
N A,B,FBI,FBMOD,FBMODA,FBMODX
;
S A=$P(X,"-"),B=$P(X,"-",2)
;
;sort modifiers so lookups will work
I B]"" D S $P(X,"-",2)=B
. F FBI=1:1 S FBMOD=$P(B,",",FBI) Q:FBMOD="" S FBMODA(FBMOD)=""
. S (FBMOD,B)=""
. F S FBMOD=$O(FBMODA(FBMOD)) Q:FBMOD="" S B=B_","_FBMOD
. S:$E(B)="," B=$E(B,2,999)
;
; check for valid pattern
I ('(X?5AN)&'(X?5AN1"-"2AN.17(1","2AN,1""))) K X Q
;
;check for valid CPT code
I $P($$CPT^ICPTCOD(A,"",1),U)'>0 D EN^DDIOL("CPT code not valid!") K X Q
;
; check for valid modifiers
I B]"" F FBI=1:1 S FBMOD=$P(B,",",FBI) Q:FBMOD="" D
. S FBMODX=$$MOD^ICPTMOD(FBMOD,"E")
. ; if modifier data not obtained then try another API to resolve it
. ; since there can be duplicate modifiers with same external value
. I $P(FBMODX,U)'>0 D
. . N FBY
. . S FBY=$$MODP^ICPTMOD(A,FBMOD,"E")
. . I $P(FBY,U)>0 S FBMODX=$$MOD^ICPTMOD($P(FBY,U),"I")
. I $P(FBMODX,U)'>0 D EN^DDIOL("CPT Modifier "_FBMOD_" not valid!") K X
Q:'$D(X)
;
;display
S FBX="CPT: "_$P($$CPT^ICPTCOD(A,"",1),U,3)
D EN^DDIOL(FBX,"","!?20")
I B]"" F FBI=1:1 S FBMOD=$P(B,",",FBI) Q:FBMOD="" D
. S FBMODX=$$MOD^ICPTMOD(FBMOD,"E")
. ; if modifier data not obtained then try another API to resolve it
. ; since there can be duplicate modifiers with same external value
. I $P(FBMODX,U)'>0 D
. . N FBY
. . S FBY=$$MODP^ICPTMOD(A,FBMOD,"E")
. . I $P(FBY,U)>0 S FBMODX=$$MOD^ICPTMOD($P(FBY,U),"I")
. S FBX="MOD: "_FBMOD_" "_$P(FBMODX,U,3)
. D EN^DDIOL(FBX,"","!?20")
Q
;
PSA(X) ;get psa from institution
;input X = ien of psa
;output station number from instutution file\
Q $S($D(^DIC(4,+$G(X),99)):$E(^(99),1,3),1:"")
;
EXTPV(X) ;call used to determine Purpose of Visit Austin code
; x = pointer to 161.82
; Output = Austin code
Q $S('$G(X):"",1:$P($G(^FBAA(161.82,+X,0)),U,3))
SUB(X) ;used to get station number and substation if one exists
;from the IFCAP software. This call is used during
;transmission of payment batches to Austin.
;
; X = "STATION NUMBER-OBLIGATION NUMBER"
; EXAMPLE: 699-C12345
I '+$G(X) Q ""
N PRCS,Y
S PRCS("X")=X,PRCS("TYPE")="FB"
D EN1^PRCS58 ;call to IFCAP to get obligation information
K PRCSCPAN
I Y=-1 Q ""
Q $S($P(Y,U,10)]"":$P(Y,U,10),1:$E($P(Y,U,2),1,3))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAUTL5 2626 printed Dec 13, 2024@01:56:50 Page 2
FBAAUTL5 ;ACAMPUS/DMK-UTILITY ROUTINE ;4/17/2000
+1 ;;3.5;FEE BASIS;**3,4,21**;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
INPUT ;called from input transform of 163.99 to determine if CPT and
+1 ;or modifier is a valid entry in appropriate file.
+2 if '$DATA(X)
QUIT
+3 NEW A,B,FBI,FBMOD,FBMODA,FBMODX
+4 ;
+5 SET A=$PIECE(X,"-")
SET B=$PIECE(X,"-",2)
+6 ;
+7 ;sort modifiers so lookups will work
+8 IF B]""
Begin DoDot:1
+9 FOR FBI=1:1
SET FBMOD=$PIECE(B,",",FBI)
if FBMOD=""
QUIT
SET FBMODA(FBMOD)=""
+10 SET (FBMOD,B)=""
+11 FOR
SET FBMOD=$ORDER(FBMODA(FBMOD))
if FBMOD=""
QUIT
SET B=B_","_FBMOD
+12 if $EXTRACT(B)=","
SET B=$EXTRACT(B,2,999)
End DoDot:1
SET $PIECE(X,"-",2)=B
+13 ;
+14 ; check for valid pattern
+15 IF ('(X?5AN)&'(X?5AN1"-"2AN.17(1","2AN,1"")))
KILL X
QUIT
+16 ;
+17 ;check for valid CPT code
+18 IF $PIECE($$CPT^ICPTCOD(A,"",1),U)'>0
DO EN^DDIOL("CPT code not valid!")
KILL X
QUIT
+19 ;
+20 ; check for valid modifiers
+21 IF B]""
FOR FBI=1:1
SET FBMOD=$PIECE(B,",",FBI)
if FBMOD=""
QUIT
Begin DoDot:1
+22 SET FBMODX=$$MOD^ICPTMOD(FBMOD,"E")
+23 ; if modifier data not obtained then try another API to resolve it
+24 ; since there can be duplicate modifiers with same external value
+25 IF $PIECE(FBMODX,U)'>0
Begin DoDot:2
+26 NEW FBY
+27 SET FBY=$$MODP^ICPTMOD(A,FBMOD,"E")
+28 IF $PIECE(FBY,U)>0
SET FBMODX=$$MOD^ICPTMOD($PIECE(FBY,U),"I")
End DoDot:2
+29 IF $PIECE(FBMODX,U)'>0
DO EN^DDIOL("CPT Modifier "_FBMOD_" not valid!")
KILL X
End DoDot:1
+30 if '$DATA(X)
QUIT
+31 ;
+32 ;display
+33 SET FBX="CPT: "_$PIECE($$CPT^ICPTCOD(A,"",1),U,3)
+34 DO EN^DDIOL(FBX,"","!?20")
+35 IF B]""
FOR FBI=1:1
SET FBMOD=$PIECE(B,",",FBI)
if FBMOD=""
QUIT
Begin DoDot:1
+36 SET FBMODX=$$MOD^ICPTMOD(FBMOD,"E")
+37 ; if modifier data not obtained then try another API to resolve it
+38 ; since there can be duplicate modifiers with same external value
+39 IF $PIECE(FBMODX,U)'>0
Begin DoDot:2
+40 NEW FBY
+41 SET FBY=$$MODP^ICPTMOD(A,FBMOD,"E")
+42 IF $PIECE(FBY,U)>0
SET FBMODX=$$MOD^ICPTMOD($PIECE(FBY,U),"I")
End DoDot:2
+43 SET FBX="MOD: "_FBMOD_" "_$PIECE(FBMODX,U,3)
+44 DO EN^DDIOL(FBX,"","!?20")
End DoDot:1
+45 QUIT
+46 ;
PSA(X) ;get psa from institution
+1 ;input X = ien of psa
+2 ;output station number from instutution file\
+3 QUIT $SELECT($DATA(^DIC(4,+$GET(X),99)):$EXTRACT(^(99),1,3),1:"")
+4 ;
EXTPV(X) ;call used to determine Purpose of Visit Austin code
+1 ; x = pointer to 161.82
+2 ; Output = Austin code
+3 QUIT $SELECT('$GET(X):"",1:$PIECE($GET(^FBAA(161.82,+X,0)),U,3))
SUB(X) ;used to get station number and substation if one exists
+1 ;from the IFCAP software. This call is used during
+2 ;transmission of payment batches to Austin.
+3 ;
+4 ; X = "STATION NUMBER-OBLIGATION NUMBER"
+5 ; EXAMPLE: 699-C12345
+6 IF '+$GET(X)
QUIT ""
+7 NEW PRCS,Y
+8 SET PRCS("X")=X
SET PRCS("TYPE")="FB"
+9 ;call to IFCAP to get obligation information
DO EN1^PRCS58
+10 KILL PRCSCPAN
+11 IF Y=-1
QUIT ""
+12 QUIT $SELECT($PIECE(Y,U,10)]"":$PIECE(Y,U,10),1:$EXTRACT($PIECE(Y,U,2),1,3))
