- 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 Mar 13, 2025@21:04:35 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
