FBNHRCS2 ;AISC/CMR-CNH/CH CENSUS DATA ;4/28/93 11:02
;;3.5;FEE BASIS;;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
NVET(X,FBDT) ;will return number of vets in cnh for a given date
;call will exclude patients on ASIH
;X=ien of vendor FBDT=date wanted
;
I $S('$G(X):1,'$G(FBDT):1,1:0) Q "000"
N FBCNT
S FBCNT=0
S FBK=0,FBJ=(FBDT-.1) F S FBJ=$O(^FB7078("AD",7,FBJ)) Q:'FBJ F S FBK=$O(^FB7078("AD",7,FBJ,FBK)) Q:'FBK D
.S FBAFDT=$P(^FB7078(FBK,0),"^",4) I FBAFDT'>FBDT S FB7078=^(0) Q:$P(FB7078,U,9)="DC"!(+$P(FB7078,U,2)'=X)!($P($P(FB7078,U,2),";",2)'="FBAAV(") D
.. K FBOUT S FBCKDT=FBAFDT,DFN=+$P(FB7078,U,3) D ASIH Q:$G(FBOUT) S FBCNT=FBCNT+1
S (FBL,FBK)=0 F S FBL=$O(^FB7078("AC","I",FBL)) Q:FBL'>0 F S FBK=$O(^FB7078("AC","I",FBL,FBK)) Q:FBK'>0 D
.S FBAFDT=$P(^FB7078(FBK,0),"^",4),FBJ=$P(^FB7078(FBK,0),"^",5) I FBAFDT'>FBDT,(FBJ'<FBDT),($P(^(0),"^",11)=7) S FB7078=^(0) Q:$P(FB7078,U,9)="DC"!(+$P(FB7078,U,2)'=X)!($P($P(FB7078,U,2),";",2)'="FBAAV(") D
.. K FBOUT S FBCKDT=FBAFDT,DFN=+$P(FB7078,U,3) D ASIH Q:$G(FBOUT) S FBCNT=FBCNT+1
;
K DFN,FBJ,FBK,FBL,FBAFDT,FB7078,FBOUT,FBCKDT,FBOUT,FBACT,FBIEN,FBREC,FBTRAN,FBTRDT,FBTRTYP
;
Q $$RJ^XLFSTR(FBCNT,3,0)
;
ASIH ;Checks to see if vet has been transferred ASIH on specified date.
S FBACT=$O(^FBAACNH("AG",DFN,X,FBCKDT)) I 'FBACT!(FBACT>FBJ) S FBOUT=1 Q
S FBIEN=$O(^FBAACNH("AG",DFN,X,FBACT,0)) I 'FBIEN S FBOUT=1 Q
I $P(^FBAACNH(FBIEN,0),"^",3)'="A" S FBCKDT=FBACT G ASIH
S FBTRAN=FBIEN F S FBTRAN=$O(^FBAACNH("AC",FBIEN,FBTRAN)) Q:FBTRAN="" Q:($P(^FBAACNH(FBTRAN,0),"^",3)="D") D
.S FBREC=$G(^FBAACNH(FBTRAN,0)),FBTRTYP=$P(FBREC,"^",7) Q:'FBTRTYP S FBTRDT=+FBREC
.I FBTRTYP<4,($P(FBTRDT,".")=FBDT) S FBOUT=1
.I FBTRTYP<4 I FBTRDT'>FBDT S FBOUT=1
.I FBTRTYP>3 I FBTRDT'>(FBDT+.99) K FBOUT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHRCS2 1857 printed Nov 22, 2024@17:09:24 Page 2
FBNHRCS2 ;AISC/CMR-CNH/CH CENSUS DATA ;4/28/93 11:02
+1 ;;3.5;FEE BASIS;;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
NVET(X,FBDT) ;will return number of vets in cnh for a given date
+1 ;call will exclude patients on ASIH
+2 ;X=ien of vendor FBDT=date wanted
+3 ;
+4 IF $SELECT('$GET(X):1,'$GET(FBDT):1,1:0)
QUIT "000"
+5 NEW FBCNT
+6 SET FBCNT=0
+7 SET FBK=0
SET FBJ=(FBDT-.1)
FOR
SET FBJ=$ORDER(^FB7078("AD",7,FBJ))
if 'FBJ
QUIT
FOR
SET FBK=$ORDER(^FB7078("AD",7,FBJ,FBK))
if 'FBK
QUIT
Begin DoDot:1
+8 SET FBAFDT=$PIECE(^FB7078(FBK,0),"^",4)
IF FBAFDT'>FBDT
SET FB7078=^(0)
if $PIECE(FB7078,U,9)="DC"!(+$PIECE(FB7078,U,2)'=X)!($PIECE($PIECE(FB7078,U,2),";",2)'="FBAAV(")
QUIT
Begin DoDot:2
+9 KILL FBOUT
SET FBCKDT=FBAFDT
SET DFN=+$PIECE(FB7078,U,3)
DO ASIH
if $GET(FBOUT)
QUIT
SET FBCNT=FBCNT+1
End DoDot:2
End DoDot:1
+10 SET (FBL,FBK)=0
FOR
SET FBL=$ORDER(^FB7078("AC","I",FBL))
if FBL'>0
QUIT
FOR
SET FBK=$ORDER(^FB7078("AC","I",FBL,FBK))
if FBK'>0
QUIT
Begin DoDot:1
+11 SET FBAFDT=$PIECE(^FB7078(FBK,0),"^",4)
SET FBJ=$PIECE(^FB7078(FBK,0),"^",5)
IF FBAFDT'>FBDT
IF (FBJ'<FBDT)
IF ($PIECE(^(0),"^",11)=7)
SET FB7078=^(0)
if $PIECE(FB7078,U,9)="DC"!(+$PIECE(FB7078,U,2)'=X)!($PIECE($PIECE(FB7078,U,2),";",2)'="FBAAV(")
QUIT
Begin DoDot:2
+12 KILL FBOUT
SET FBCKDT=FBAFDT
SET DFN=+$PIECE(FB7078,U,3)
DO ASIH
if $GET(FBOUT)
QUIT
SET FBCNT=FBCNT+1
End DoDot:2
End DoDot:1
+13 ;
+14 KILL DFN,FBJ,FBK,FBL,FBAFDT,FB7078,FBOUT,FBCKDT,FBOUT,FBACT,FBIEN,FBREC,FBTRAN,FBTRDT,FBTRTYP
+15 ;
+16 QUIT $$RJ^XLFSTR(FBCNT,3,0)
+17 ;
ASIH ;Checks to see if vet has been transferred ASIH on specified date.
+1 SET FBACT=$ORDER(^FBAACNH("AG",DFN,X,FBCKDT))
IF 'FBACT!(FBACT>FBJ)
SET FBOUT=1
QUIT
+2 SET FBIEN=$ORDER(^FBAACNH("AG",DFN,X,FBACT,0))
IF 'FBIEN
SET FBOUT=1
QUIT
+3 IF $PIECE(^FBAACNH(FBIEN,0),"^",3)'="A"
SET FBCKDT=FBACT
GOTO ASIH
+4 SET FBTRAN=FBIEN
FOR
SET FBTRAN=$ORDER(^FBAACNH("AC",FBIEN,FBTRAN))
if FBTRAN=""
QUIT
if ($PIECE(^FBAACNH(FBTRAN,0),"^",3)="D")
QUIT
Begin DoDot:1
+5 SET FBREC=$GET(^FBAACNH(FBTRAN,0))
SET FBTRTYP=$PIECE(FBREC,"^",7)
if 'FBTRTYP
QUIT
SET FBTRDT=+FBREC
+6 IF FBTRTYP<4
IF ($PIECE(FBTRDT,".")=FBDT)
SET FBOUT=1
+7 IF FBTRTYP<4
IF FBTRDT'>FBDT
SET FBOUT=1
+8 IF FBTRTYP>3
IF FBTRDT'>(FBDT+.99)
KILL FBOUT
End DoDot:1
+9 QUIT
