FBCNHCEN ;AISC/CMR-CNH/CH CENSUS DATA ;1/13/98
 ;;3.5;FEE BASIS;**12**;JAN 30, 1995
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
 ;FBI is set in option entry action, 6=CH, 7=CNH
 I $G(FBI)'=6&($G(FBI)'=7) W "Inpatient type is not identified." Q
 W !!,"****CENSUS DATE SELECTION****"
 W ! S %DT="APEX",%DT("A")="   Census DATE:  " D ^%DT G END:Y<0  S FBDT=Y K %DT
 W ! S DIR(0)="Y",DIR("A")="Display Address for Vendors",DIR("B")="No" D ^DIR K DIR Q:$D(DIRUT)  S FBADDCK=Y
 S VAR="FBDT^FBI^FBADDCK",VAL=FBDT_"^"_FBI_"^"_FBADDCK,PGM="START^FBCNHCEN" D ZIS^FBAAUTL G END:FBPOP
START S Q="=",$P(Q,"=",80)="=",QQ="-",$P(QQ,"-",38)="-",FBAAOUT=0 K ^TMP($J) U IO W:$E(IOST,1,2)["C-" @IOF D HED
 S FBK=0,FBJ=(FBDT-.1) F  S FBJ=$O(^FB7078("AD",FBI,FBJ)) Q:FBJ'>0  F  S FBK=$O(^FB7078("AD",FBI,FBJ,FBK)) Q:FBK'>0  D
 .S FBAFDT=$P(^FB7078(FBK,0),"^",4) I FBAFDT'>FBDT S FB7078=^(0) Q:$P(FB7078,U,9)="DC"  D GOT
 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)=FBI) S FB7078=^(0) Q:$P(FB7078,U,9)="DC"  D GOT
 S FBVNAME="",FBVIEN=0
 F  S FBVNAME=$O(^TMP($J,"FBCEN",FBVNAME)) Q:FBVNAME=""!(FBAAOUT)  F  S FBVIEN=$O(^TMP($J,"FBCEN",FBVNAME,FBVIEN)) Q:'FBVIEN  S FBNAME=0 D HED1 Q:FBAAOUT  F  S FBNAME=$O(^TMP($J,"FBCEN",FBVNAME,FBVIEN,FBNAME)) Q:FBNAME=""!(FBAAOUT)  D
 .S DFN=0 F  S DFN=$O(^TMP($J,"FBCEN",FBVNAME,FBVIEN,FBNAME,DFN)) Q:'DFN  S FB7078=^TMP($J,"FBCEN",FBVNAME,FBVIEN,FBNAME,DFN),FBDOB=+FB7078,FBAFD=$P(FB7078,"^",2),FBPSA=$P(FB7078,"^",3) D PRINT
END K FBDT,Q,QQ,FBAAOUT,FBI,FBJ,FBK,FBVNAME,FBNAME,FB7078,DFN,FBDOB,FBAFD,FBZ,^TMP($J,"FBCEN"),FBPSA,JJ,X,Y,FBOUT,FBL,FBAFDT,FBACT,FBCKDT,FBIEN,FBREC,FBTRAN,FBTRDT,FBTRTYP,FBOUT,FBADDCK
 D CLOSE^FBAAUTL Q
GOT S DFN=$P(FB7078,"^",3),FBZ=$P(FB7078,"^",2) Q:$P(FBZ,";",2)'="FBAAV("
 I FBI=7 K FBOUT S FBCKDT=FBAFDT D ASIH Q:$G(FBOUT)
 S FBNAME=$$NAME^FBCHREQ2(DFN),FBDOB=$P(^DPT(DFN,0),"^",3),FBAFD=$P(FB7078,"^",4)
 S FBVNAME=$P($G(^FBAAV(+FBZ,0)),"^") Q:FBVNAME=""  S FBVNAME=$E(FBVNAME,1,23)
 S JJ=0,FBPSA="",JJ=$O(^FBAAA("AG",FBK_";FB7078(",DFN,JJ)) I JJ S FBPSA=$P($G(^FBAAA(DFN,1,JJ,0)),"^",5)
 S ^TMP($J,"FBCEN",FBVNAME,+FBZ)="",^TMP($J,"FBCEN",FBVNAME,+FBZ,FBNAME,DFN)=FBDOB_"^"_FBAFD_"^"_FBPSA_"^"_FBK
 Q
PRINT I $Y+3>IOSL,($E(IOST,1,2)["C-") S DIR(0)="E" D ^DIR K DIR I 'Y S FBAAOUT=1 Q
 I $Y+3>IOSL W @IOF D HED,HED1
 W !?4,FBNAME,?32,$$FMTE^XLFDT(FBDOB),?46,$$SSN^FBAAUTL(DFN),?60,$$PSA^FBAAUTL5(FBPSA),?67,$$FMTE^XLFDT(FBAFD)
 Q
HED W !?20,"FEE BASIS ",$S(FBI=6:"CIVIL HOSPITAL",FBI=7:"CONTRACT NURSING HOME",1:"UNKNOWN")," CENSUS",!?31,$$FMTE^XLFDT(FBDT),!?20,$S(FBI=6:$E(QQ,1,31),1:QQ)
 W !!,"VENDOR NAME",?40,"VENDOR ID",!?4,"VETERAN NAME",?36,"DOB",?46,"VETERAN ID",?60,"PSA",?67,"AUTH FROM",!,Q
 Q
HED1 I $Y+8>IOSL,($E(IOST,1,2)["C-") S DIR(0)="E" D ^DIR I 'Y S FBAAOUT=1 Q
 I $Y+8>IOSL W @IOF D HED
 W !!!,FBVNAME I FBADDCK S Y=FBVIEN D ^FBVDISP Q
 W ?40,$$VID^FBNHEXP(FBVIEN) Q
ASIH ;Checks to see if vet has been transferred ASIH on specified date.
 S FBACT=$O(^FBAACNH("AG",DFN,+FBZ,FBCKDT)) I 'FBACT!(FBACT>FBJ) S FBOUT=1 Q
 S FBIEN=$O(^FBAACNH("AG",DFN,+FBZ,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