FBPHON1 ;AISC/CMR-LIST PAYMENTS CONT. ;5/13/1999
;;3.5;FEE BASIS;**4,69**;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
GATHER(DFN,FBV) ;gather vendor/veteran specific payment info
;required input DFN = veteran ien
; FBV = vendor ien
;output ^TMP($J,"FBPHON", containing pmnts for all programs
N FBCNT,FBI,FBJ,FBK,FBSDI,FBAADT,FBAACPI,FBX,FBMODLE,FBXAD,FBXADJC
Q:'$G(DFN)!('$G(FBV))
S FBCNT=0
OPT ;gather opt payments
S FBSDI=0 F S FBSDI=$O(^FBAAC(DFN,1,FBV,1,FBSDI)) Q:'FBSDI S FBAADT=+^(FBSDI,0),FBAACPI=0 F S FBAACPI=$O(^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI)) Q:'FBAACPI D
.S FBMODLE=$$MODL^FBAAUTL4("^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1,"_FBAACPI_",""M"")","E")
.S FBX=^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI,0),FBFL=$S($P(FBX,U,20)="R":"*",1:""),FBFL=FBFL_$S($P(FBX,U,21)="VP":"#",1:""),FBCNT=FBCNT+1
.S FBXAD=$$ADJLRA^FBAAFA(FBAACPI_","_FBSDI_","_FBV_","_DFN_",")
.S FBXADJC=$P(FBXAD,U,1) ;Adjustment code list
.I FBXADJC["," S FBXADJC=$P(FBXADJC,",",1)_"&" ;More than one adj code
.I FBXADJC="" S FBXADJC=$P(FBX,U,5) ;No adj codes use Suspense code
.S ^TMP($J,"FBPHON",-FBAADT,FBCNT)="OPT"_"^"_FBAADT_"^"_$$CPT^FBAAUTL4(+FBX)_$S($G(FBMODLE)]"":"-"_FBMODLE,1:"")_"^"_$P(FBX,U,2)_"^"_$P(FBX,U,3)_"^"_FBXADJC_"^"_$P(FBX,U,16)_"^"_$P(FBX,U,8)_"^"_DFN_","_FBV_","_FBSDI_","_FBAACPI_"^"_FBFL
.K FBX,FBFL
K FBSDI,FBAACPI,FBAADT
INP ;gather inpt payments
S FBI=0 F S FBI=$O(^FBAAI("AK",DFN,FBV,FBI)) Q:'FBI I $D(^FBAAI(FBI,0)) S FBX=^FBAAI(FBI,0),FBCNT=FBCNT+1,FBFL=$S($P(FBX,U,13)="R":"*",1:""),FBFL=FBFL_$S($P(FBX,U,14)="VP":"#",1:"") D
.S FBXAD=$$ADJLRA^FBCHFA(FBI_",")
.S FBXADJC=$P(FBXAD,U)
.I FBXADJC["," S FBXADJC=$P(FBXADJC,",",1)_"&" ;More than one adj code
.I FBXADJC="" S FBXADJC=$P(FBX,U,11) ;No adj codes use Suspense code
.S ^TMP($J,"FBPHON",-$P(FBX,U,6),FBCNT)=$S($P(FBX,U,12)=6:"CH",$P(FBX,U,12)=7:"CNH",1:"")_"^"_$P(FBX,U,6)_"-"_$P(FBX,U,7)_"^^"_$P(FBX,U,8)_"^"_$P(FBX,U,9)_"^"_FBXADJC_"^"_+FBX_"^"_$P(FBX,U,17)_"^"_FBI_"^"_FBFL
.K FBX,FBFL
K FBI
PHARM ;gather pharm payments
S FBAADT=0 F S FBAADT=$O(^FBAA(162.1,"AD",DFN,FBAADT)) Q:'FBAADT S FBI=0 F S FBI=$O(^FBAA(162.1,"AD",DFN,FBAADT,FBI)) Q:'FBI I $D(^FBAA(162.1,"AN",FBV,FBI)) D
.S FBJ=0 F S FBJ=$O(^FBAA(162.1,"AD",DFN,FBAADT,FBI,FBJ)) Q:'FBJ I $D(^FBAA(162.1,FBI,"RX",FBJ,0)) S FBX=^(0),FBFL=$S($P(FBX,U,20)="R":"*",1:""),FBFL=FBFL_$S($P($G(^FBAA(162.1,FBI,"RX",FBJ,2)),U,3)="VP":"#",1:"") D
..S FBCNT=FBCNT+1
..S FBXAD=$$ADJLRA^FBRXFA(FBJ_","_FBI_",")
..S FBXADJC=$P(FBXAD,U,1) ;Adjustment code list
..I FBXADJC["," S FBXADJC=$P(FBXADJC,",",1)_"&" ;More than one adj code
..I FBXADJC="" S FBXADJC=$P(FBX,U,8)
..S ^TMP($J,"FBPHON",-(9999999-FBAADT),FBCNT)="PHAR^"_(9999999-FBAADT)_"^"_$P(FBX,U)_"^"_$P(FBX,U,4)_"^"_$P(FBX,U,16)_"^"_FBXADJC_"^"_+$G(^FBAA(162.1,FBI,0))_"^"_$P(FBX,U,17)_"^"_FBI_","_FBJ_"^"_FBFL
.K FBX,FBFL
K FBAADT,FBI,FBJ
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBPHON1 2949 printed Oct 16, 2024@18:00:31 Page 2
FBPHON1 ;AISC/CMR-LIST PAYMENTS CONT. ;5/13/1999
+1 ;;3.5;FEE BASIS;**4,69**;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
GATHER(DFN,FBV) ;gather vendor/veteran specific payment info
+1 ;required input DFN = veteran ien
+2 ; FBV = vendor ien
+3 ;output ^TMP($J,"FBPHON", containing pmnts for all programs
+4 NEW FBCNT,FBI,FBJ,FBK,FBSDI,FBAADT,FBAACPI,FBX,FBMODLE,FBXAD,FBXADJC
+5 if '$GET(DFN)!('$GET(FBV))
QUIT
+6 SET FBCNT=0
OPT ;gather opt payments
+1 SET FBSDI=0
FOR
SET FBSDI=$ORDER(^FBAAC(DFN,1,FBV,1,FBSDI))
if 'FBSDI
QUIT
SET FBAADT=+^(FBSDI,0)
SET FBAACPI=0
FOR
SET FBAACPI=$ORDER(^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI))
if 'FBAACPI
QUIT
Begin DoDot:1
+2 SET FBMODLE=$$MODL^FBAAUTL4("^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1,"_FBAACPI_",""M"")","E")
+3 SET FBX=^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI,0)
SET FBFL=$SELECT($PIECE(FBX,U,20)="R":"*",1:"")
SET FBFL=FBFL_$SELECT($PIECE(FBX,U,21)="VP":"#",1:"")
SET FBCNT=FBCNT+1
+4 SET FBXAD=$$ADJLRA^FBAAFA(FBAACPI_","_FBSDI_","_FBV_","_DFN_",")
+5 ;Adjustment code list
SET FBXADJC=$PIECE(FBXAD,U,1)
+6 ;More than one adj code
IF FBXADJC[","
SET FBXADJC=$PIECE(FBXADJC,",",1)_"&"
+7 ;No adj codes use Suspense code
IF FBXADJC=""
SET FBXADJC=$PIECE(FBX,U,5)
+8 SET ^TMP($JOB,"FBPHON",-FBAADT,FBCNT)="OPT"_"^"_FBAADT_"^"_$$CPT^FBAAUTL4(+FBX)_$SELECT($GET(FBMODLE)]"":"-"_FBMODLE,1:"")_"^"_$PIECE(FBX,U,2)_"^"_...
... $PIECE(FBX,U,3)_"^"_FBXADJC_"^"_$PIECE(FBX,U,16)_"^"_$PIECE(FBX,U,8)_"^"_DFN_","_FBV_","_FBSDI_","_FBAACPI_"^"_FBFL
+9 KILL FBX,FBFL
End DoDot:1
+10 KILL FBSDI,FBAACPI,FBAADT
INP ;gather inpt payments
+1 SET FBI=0
FOR
SET FBI=$ORDER(^FBAAI("AK",DFN,FBV,FBI))
if 'FBI
QUIT
IF $DATA(^FBAAI(FBI,0))
SET FBX=^FBAAI(FBI,0)
SET FBCNT=FBCNT+1
SET FBFL=$SELECT($PIECE(FBX,U,13)="R":"*",1:"")
SET FBFL=FBFL_$SELECT($PIECE(FBX,U,14)="VP":"#",1:"")
Begin DoDot:1
+2 SET FBXAD=$$ADJLRA^FBCHFA(FBI_",")
+3 SET FBXADJC=$PIECE(FBXAD,U)
+4 ;More than one adj code
IF FBXADJC[","
SET FBXADJC=$PIECE(FBXADJC,",",1)_"&"
+5 ;No adj codes use Suspense code
IF FBXADJC=""
SET FBXADJC=$PIECE(FBX,U,11)
+6 SET ^TMP($JOB,"FBPHON",-$PIECE(FBX,U,6),FBCNT)=$SELECT($PIECE(FBX,U,12)=6:"CH",$PIECE(FBX,U,12)=7:"CNH",1:"")_"^"_$PIECE(FBX,U,6)_"-"_$PIECE(FBX,U,7)_"^^"_$PIECE(FBX,U,8)_"^"_$PIECE(FBX,U,9)_"^"_FBXADJC_"^"_+FBX_"^"_$PIECE(FBX,U,17)
_"^"_FBI_"^"_FBFL
+7 KILL FBX,FBFL
End DoDot:1
+8 KILL FBI
PHARM ;gather pharm payments
+1 SET FBAADT=0
FOR
SET FBAADT=$ORDER(^FBAA(162.1,"AD",DFN,FBAADT))
if 'FBAADT
QUIT
SET FBI=0
FOR
SET FBI=$ORDER(^FBAA(162.1,"AD",DFN,FBAADT,FBI))
if 'FBI
QUIT
IF $DATA(^FBAA(162.1,"AN",FBV,FBI))
Begin DoDot:1
+2 SET FBJ=0
FOR
SET FBJ=$ORDER(^FBAA(162.1,"AD",DFN,FBAADT,FBI,FBJ))
if 'FBJ
QUIT
IF $DATA(^FBAA(162.1,FBI,"RX",FBJ,0))
SET FBX=^(0)
SET FBFL=$SELECT($PIECE(FBX,U,20)="R":"*",1:"")
SET FBFL=FBFL_$SELECT($PIECE($GET(^FBAA(162.1,FBI,"RX",FBJ,2)),U,3)="VP":"#",1:"")
Begin DoDot:2
+3 SET FBCNT=FBCNT+1
+4 SET FBXAD=$$ADJLRA^FBRXFA(FBJ_","_FBI_",")
+5 ;Adjustment code list
SET FBXADJC=$PIECE(FBXAD,U,1)
+6 ;More than one adj code
IF FBXADJC[","
SET FBXADJC=$PIECE(FBXADJC,",",1)_"&"
+7 IF FBXADJC=""
SET FBXADJC=$PIECE(FBX,U,8)
+8 SET ^TMP($JOB,"FBPHON",-(9999999-FBAADT),FBCNT)="PHAR^"_(9999999-FBAADT)_"^"_$PIECE(FBX,U)_"^"_$PIECE(FBX,U,4)_"^"_$PIECE(FBX,U,16)_"^"_FBXADJC_"^"_+$GET(^FBAA(162.1,FBI,0))_"^"_$PIECE(FBX,U,17)_"^"_FBI_","_FBJ_"^"_F
BFL
End DoDot:2
+9 KILL FBX,FBFL
End DoDot:1
+10 KILL FBAADT,FBI,FBJ
+11 QUIT
