source: FOIAVistA/tag/r/FEE_BASIS-FB/FBNHRCS2.m@ 628

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