- FBNHAMI1 ;AISC/CMR-CALCULATE/VALIDATE AMIS 349 ;11/18/94
- ;;3.5;FEE BASIS;;JAN 30, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- NEXT ;
- F FBDD=FBPAYDT:0 S FBDD=$O(^FB7078("AD",7,FBDD)) Q:FBDD'>0 F FBIFN=0:0 S FBIFN=$O(^FB7078("AD",7,FBDD,FBIFN)) Q:FBIFN'>0 S FBZ=$G(^FB7078(FBIFN,0)) I $P(FBZ,U,9)'="DC",($P(FBZ,U,4)'>FBENDDT) D
- .S DFN=+$P(FBZ,"^",3),IFN=+$P(FBZ,"^",2) D MORE I $G(FBCUR) S TOTDAYS=TOTDAYS+FBTRDYS D TMP(15) S FBTRDYS=0
- Q:'$G(FBCUR)
- S TOTDAYS=$FN(TOTDAYS,",",0) D ^FBNHPAMS G END^FBNHAMIS
- MORE K FB S FBNAC=$O(^FBAACNH("AG",DFN,IFN,FBPAYDT)) G:'FBNAC!($P(FBNAC,".")>FBENDDT) NOAC
- F FBNAC=FBPAYDT:0 S FBNAC=$O(^FBAACNH("AG",DFN,IFN,FBNAC)) Q:'FBNAC!(FBNAC>FBENDDT) F FBRIFN=0:0 S FBRIFN=$O(^FBAACNH("AG",DFN,IFN,FBNAC,FBRIFN)) Q:'FBRIFN S Z=$G(^FBAACNH(FBRIFN,0)),Z(0)=$P(Z,"^",3) D
- .N FBZZ S FBZZ=$S(Z(0)="A":+$P(Z,"^",10),1:+$P(^FBAACNH($P(Z,"^",5),0),"^",10)) Q:'$D(^FBAAA("AG",FBIFN_";FB7078(",DFN,FBZZ))
- .S FB(FBRIFN)=FBNAC\1_"^"_Z(0)_"^"_$S(Z(0)="A":9,Z(0)="D":0,1:$P(Z,"^",7))
- S I=0,FBPNAC=FBPAYDT+1,(FBPSW,FBSW)=""
- F S I=$O(FB(I)) Q:'I D:$P(FB(I),"^")'>FBENDDT
- .S FBNAC=$P(FB(I),"^"),FBSW=$P(FB(I),"^",3) I FBSW<4&(FBPSW="") D
- ..S FBPREV=$O(^FBAACNH("AF",+DFN,(9999999.9999-FBPAYDT))) Q:'FBPREV S FBPREV=$O(^(FBPREV,0)),Z=$G(^FBAACNH(+FBPREV,0)),Z(0)=$P(Z,"^",3),FBPSW=$S(Z(0)="A":9,Z(0)="D":0,1:$P(Z,"^",7))
- .S:FBSW<4&(FBPSW>3!(FBPSW="")) FBTRDYS=FBTRDYS+$S((FBNAC-FBPNAC)>0:(FBNAC-FBPNAC),((FBPSW>3)&(+$E(FBNAC,6,7)=1)&(FBNAC'=+$P(Z,"."))):0,1:1) S FBPNAC=FBNAC,FBPSW=FBSW
- I FBSW>3 S FBTRDYS=FBTRDYS+$S((FBENDDT\1-FBNAC)>0:(FBENDDT\1-FBNAC),FBENDDT\1=FBNAC:0,1:1),FBTRDYS=$S(FBTRDYS>0:(FBTRDYS+1),1:1) D
- .S FBR(1)=FBR(1)+1 D TMP(9)
- .I $P($G(^DPT(+DFN,0)),"^",2)="F" S FBFEM=FBFEM+1 D TMP(12)
- I FBSW<4 D
- .I $S(FBSW=1:1,FBSW=2:1,1:0) S FBR(2)=FBR(2)+1 D TMP(10)
- .I FBSW=3 S FBR(3)=FBR(3)+1 D TMP(11)
- I $D(FB) D ERR
- Q
- NOAC S FBPREV=$O(^FBAACNH("AF",DFN,(9999999.9999-FBPAYDT))) Q:'FBPREV S FBPIFN=$O(^(FBPREV,0)),Z=$G(^FBAACNH(FBPIFN,0)) Q:$P(Z,"^",3)="D" S Z(0)=$P(Z,"^",3)
- N FBZZ S FBZZ=$S(Z(0)="A":+$P(Z,"^",10),1:+$P(^FBAACNH($P(Z,"^",5),0),"^",10))
- Q:'$D(^FBAAA("AG",FBIFN_";FB7078(",DFN,FBZZ))
- D ERR
- I $P(Z,"^",3)="T"&($P(Z,"^",7)<4) S:$P(Z,"^",7)=3 FBR(3)=FBR(3)+1 D TMP(11) Q
- S FBTRDYS=FBDAYS,FBR(1)=FBR(1)+1 D TMP(9)
- I $P($G(^DPT(+DFN,0)),"^",2)="F" S FBFEM=FBFEM+1 D TMP(12)
- I $S($P(Z,"^",7)=1:1,$P(Z,"^",7)=2:1,1:0) S FBR(2)=FBR(2)+1 D TMP(10)
- Q
- TMP(X) ;set tmp
- Q:'X!('$G(FBCUR))!('$G(FBVAL))
- S ^TMP($J,"FBAMIS",X,FBIFN)=$S(X=15:FBTRDYS,1:"")
- Q
- ERR ;check if authorization to date has been exceeded
- Q:FBDD>FBENDDT
- N FBDATE,FBIEN,FBZM
- S FBER(DFN,FBDD)=$G(FBCUR)
- S FBDATE=$S($P(FBZ,U,4)>FBPAYDT:$P(FBZ,U,4),1:FBPAYDT)
- F S FBDATE=$O(^FBAACNH("AG",DFN,IFN,FBDATE)) Q:'FBDATE!(FBDATE>($E(FBDD,1,7)_.9999)) S FBIEN=0 F S FBIEN=$O(^FBAACNH("AG",DFN,IFN,FBDATE,FBIEN)) Q:'FBIEN S FBZM=$G(^FBAACNH(FBIEN,0)) D:$P(FBZM,"^",3)["D" K FBZM
- .S FBZZ=+$P(^FBAACNH($P(FBZM,"^",5),0),"^",10) I $D(^FBAAA("AG",FBIFN_";FB7078(",DFN,FBZZ)) K FBER(DFN,FBDD)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHAMI1 3098 printed Mar 13, 2025@21:03:36 Page 2
- FBNHAMI1 ;AISC/CMR-CALCULATE/VALIDATE AMIS 349 ;11/18/94
- +1 ;;3.5;FEE BASIS;;JAN 30, 1995
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- NEXT ;
- +1 FOR FBDD=FBPAYDT:0
- SET FBDD=$ORDER(^FB7078("AD",7,FBDD))
- if FBDD'>0
- QUIT
- FOR FBIFN=0:0
- SET FBIFN=$ORDER(^FB7078("AD",7,FBDD,FBIFN))
- if FBIFN'>0
- QUIT
- SET FBZ=$GET(^FB7078(FBIFN,0))
- IF $PIECE(FBZ,U,9)'="DC"
- IF ($PIECE(FBZ,U,4)'>FBENDDT)
- Begin DoDot:1
- +2 SET DFN=+$PIECE(FBZ,"^",3)
- SET IFN=+$PIECE(FBZ,"^",2)
- DO MORE
- IF $GET(FBCUR)
- SET TOTDAYS=TOTDAYS+FBTRDYS
- DO TMP(15)
- SET FBTRDYS=0
- End DoDot:1
- +3 if '$GET(FBCUR)
- QUIT
- +4 SET TOTDAYS=$FNUMBER(TOTDAYS,",",0)
- DO ^FBNHPAMS
- GOTO END^FBNHAMIS
- MORE KILL FB
- SET FBNAC=$ORDER(^FBAACNH("AG",DFN,IFN,FBPAYDT))
- if 'FBNAC!($PIECE(FBNAC,".")>FBENDDT)
- GOTO NOAC
- +1 FOR FBNAC=FBPAYDT:0
- SET FBNAC=$ORDER(^FBAACNH("AG",DFN,IFN,FBNAC))
- if 'FBNAC!(FBNAC>FBENDDT)
- QUIT
- FOR FBRIFN=0:0
- SET FBRIFN=$ORDER(^FBAACNH("AG",DFN,IFN,FBNAC,FBRIFN))
- if 'FBRIFN
- QUIT
- SET Z=$GET(^FBAACNH(FBRIFN,0))
- SET Z(0)=$PIECE(Z,"^",3)
- Begin DoDot:1
- +2 NEW FBZZ
- SET FBZZ=$SELECT(Z(0)="A":+$PIECE(Z,"^",10),1:+$PIECE(^FBAACNH($PIECE(Z,"^",5),0),"^",10))
- if '$DATA(^FBAAA("AG",FBIFN_";FB7078(",DFN,FBZZ))
- QUIT
- +3 SET FB(FBRIFN)=FBNAC\1_"^"_Z(0)_"^"_$SELECT(Z(0)="A":9,Z(0)="D":0,1:$PIECE(Z,"^",7))
- End DoDot:1
- +4 SET I=0
- SET FBPNAC=FBPAYDT+1
- SET (FBPSW,FBSW)=""
- +5 FOR
- SET I=$ORDER(FB(I))
- if 'I
- QUIT
- if $PIECE(FB(I),"^")'>FBENDDT
- Begin DoDot:1
- +6 SET FBNAC=$PIECE(FB(I),"^")
- SET FBSW=$PIECE(FB(I),"^",3)
- IF FBSW<4&(FBPSW="")
- Begin DoDot:2
- +7 SET FBPREV=$ORDER(^FBAACNH("AF",+DFN,(9999999.9999-FBPAYDT)))
- if 'FBPREV
- QUIT
- SET FBPREV=$ORDER(^(FBPREV,0))
- SET Z=$GET(^FBAACNH(+FBPREV,0))
- SET Z(0)=$PIECE(Z,"^",3)
- SET FBPSW=$SELECT(Z(0)="A":9,Z(0)="D":0,1:$PIECE(Z,"^",7))
- End DoDot:2
- +8 if FBSW<4&(FBPSW>3!(FBPSW=""))
- SET FBTRDYS=FBTRDYS+$SELECT((FBNAC-FBPNAC)>0:(FBNAC-FBPNAC),((FBPSW>3)&(+$EXTRACT(FBNAC,6,7)=1)&(FBNAC'=+$PIECE(Z,"."))):0,1:1)
- SET FBPNAC=FBNAC
- SET FBPSW=FBSW
- End DoDot:1
- +9 IF FBSW>3
- SET FBTRDYS=FBTRDYS+$SELECT((FBENDDT\1-FBNAC)>0:(FBENDDT\1-FBNAC),FBENDDT\1=FBNAC:0,1:1)
- SET FBTRDYS=$SELECT(FBTRDYS>0:(FBTRDYS+1),1:1)
- Begin DoDot:1
- +10 SET FBR(1)=FBR(1)+1
- DO TMP(9)
- +11 IF $PIECE($GET(^DPT(+DFN,0)),"^",2)="F"
- SET FBFEM=FBFEM+1
- DO TMP(12)
- End DoDot:1
- +12 IF FBSW<4
- Begin DoDot:1
- +13 IF $SELECT(FBSW=1:1,FBSW=2:1,1:0)
- SET FBR(2)=FBR(2)+1
- DO TMP(10)
- +14 IF FBSW=3
- SET FBR(3)=FBR(3)+1
- DO TMP(11)
- End DoDot:1
- +15 IF $DATA(FB)
- DO ERR
- +16 QUIT
- NOAC SET FBPREV=$ORDER(^FBAACNH("AF",DFN,(9999999.9999-FBPAYDT)))
- if 'FBPREV
- QUIT
- SET FBPIFN=$ORDER(^(FBPREV,0))
- SET Z=$GET(^FBAACNH(FBPIFN,0))
- if $PIECE(Z,"^",3)="D"
- QUIT
- SET Z(0)=$PIECE(Z,"^",3)
- +1 NEW FBZZ
- SET FBZZ=$SELECT(Z(0)="A":+$PIECE(Z,"^",10),1:+$PIECE(^FBAACNH($PIECE(Z,"^",5),0),"^",10))
- +2 if '$DATA(^FBAAA("AG",FBIFN_";FB7078(",DFN,FBZZ))
- QUIT
- +3 DO ERR
- +4 IF $PIECE(Z,"^",3)="T"&($PIECE(Z,"^",7)<4)
- if $PIECE(Z,"^",7)=3
- SET FBR(3)=FBR(3)+1
- DO TMP(11)
- QUIT
- +5 SET FBTRDYS=FBDAYS
- SET FBR(1)=FBR(1)+1
- DO TMP(9)
- +6 IF $PIECE($GET(^DPT(+DFN,0)),"^",2)="F"
- SET FBFEM=FBFEM+1
- DO TMP(12)
- +7 IF $SELECT($PIECE(Z,"^",7)=1:1,$PIECE(Z,"^",7)=2:1,1:0)
- SET FBR(2)=FBR(2)+1
- DO TMP(10)
- +8 QUIT
- TMP(X) ;set tmp
- +1 if 'X!('$GET(FBCUR))!('$GET(FBVAL))
- QUIT
- +2 SET ^TMP($JOB,"FBAMIS",X,FBIFN)=$SELECT(X=15:FBTRDYS,1:"")
- +3 QUIT
- ERR ;check if authorization to date has been exceeded
- +1 if FBDD>FBENDDT
- QUIT
- +2 NEW FBDATE,FBIEN,FBZM
- +3 SET FBER(DFN,FBDD)=$GET(FBCUR)
- +4 SET FBDATE=$SELECT($PIECE(FBZ,U,4)>FBPAYDT:$PIECE(FBZ,U,4),1:FBPAYDT)
- +5 FOR
- SET FBDATE=$ORDER(^FBAACNH("AG",DFN,IFN,FBDATE))
- if 'FBDATE!(FBDATE>($EXTRACT(FBDD,1,7)_.9999))
- QUIT
- SET FBIEN=0
- FOR
- SET FBIEN=$ORDER(^FBAACNH("AG",DFN,IFN,FBDATE,FBIEN))
- if 'FBIEN
- QUIT
- SET FBZM=$GET(^FBAACNH(FBIEN,0))
- if $PIECE(FBZM,"^",3)["D"
- Begin DoDot:1
- +6 SET FBZZ=+$PIECE(^FBAACNH($PIECE(FBZM,"^",5),0),"^",10)
- IF $DATA(^FBAAA("AG",FBIFN_";FB7078(",DFN,FBZZ))
- KILL FBER(DFN,FBDD)
- End DoDot:1
- KILL FBZM
- +7 QUIT
