32 lines
1.8 KiB
Mathematica
32 lines
1.8 KiB
Mathematica
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
|