- 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 Feb 18, 2025@23:25:39 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