source: FOIAVistA/trunk/r/FEE_BASIS-FB/FBCNHCEN.m@ 794

Last change on this file since 794 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.6 KB
Line 
1FBCNHCEN ;AISC/CMR-CNH/CH CENSUS DATA ;1/13/98
2 ;;3.5;FEE BASIS;**12**;JAN 30, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;FBI is set in option entry action, 6=CH, 7=CNH
5 I $G(FBI)'=6&($G(FBI)'=7) W "Inpatient type is not identified." Q
6 W !!,"****CENSUS DATE SELECTION****"
7 W ! S %DT="APEX",%DT("A")=" Census DATE: " D ^%DT G END:Y<0 S FBDT=Y K %DT
8 W ! S DIR(0)="Y",DIR("A")="Display Address for Vendors",DIR("B")="No" D ^DIR K DIR Q:$D(DIRUT) S FBADDCK=Y
9 S VAR="FBDT^FBI^FBADDCK",VAL=FBDT_"^"_FBI_"^"_FBADDCK,PGM="START^FBCNHCEN" D ZIS^FBAAUTL G END:FBPOP
10START 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
11 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
12 .S FBAFDT=$P(^FB7078(FBK,0),"^",4) I FBAFDT'>FBDT S FB7078=^(0) Q:$P(FB7078,U,9)="DC" D GOT
13 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
14 .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
15 S FBVNAME="",FBVIEN=0
16 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
17 .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
18END 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
19 D CLOSE^FBAAUTL Q
20GOT S DFN=$P(FB7078,"^",3),FBZ=$P(FB7078,"^",2) Q:$P(FBZ,";",2)'="FBAAV("
21 I FBI=7 K FBOUT S FBCKDT=FBAFDT D ASIH Q:$G(FBOUT)
22 S FBNAME=$$NAME^FBCHREQ2(DFN),FBDOB=$P(^DPT(DFN,0),"^",3),FBAFD=$P(FB7078,"^",4)
23 S FBVNAME=$P($G(^FBAAV(+FBZ,0)),"^") Q:FBVNAME="" S FBVNAME=$E(FBVNAME,1,23)
24 S JJ=0,FBPSA="",JJ=$O(^FBAAA("AG",FBK_";FB7078(",DFN,JJ)) I JJ S FBPSA=$P($G(^FBAAA(DFN,1,JJ,0)),"^",5)
25 S ^TMP($J,"FBCEN",FBVNAME,+FBZ)="",^TMP($J,"FBCEN",FBVNAME,+FBZ,FBNAME,DFN)=FBDOB_"^"_FBAFD_"^"_FBPSA_"^"_FBK
26 Q
27PRINT I $Y+3>IOSL,($E(IOST,1,2)["C-") S DIR(0)="E" D ^DIR K DIR I 'Y S FBAAOUT=1 Q
28 I $Y+3>IOSL W @IOF D HED,HED1
29 W !?4,FBNAME,?32,$$FMTE^XLFDT(FBDOB),?46,$$SSN^FBAAUTL(DFN),?60,$$PSA^FBAAUTL5(FBPSA),?67,$$FMTE^XLFDT(FBAFD)
30 Q
31HED 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)
32 W !!,"VENDOR NAME",?40,"VENDOR ID",!?4,"VETERAN NAME",?36,"DOB",?46,"VETERAN ID",?60,"PSA",?67,"AUTH FROM",!,Q
33 Q
34HED1 I $Y+8>IOSL,($E(IOST,1,2)["C-") S DIR(0)="E" D ^DIR I 'Y S FBAAOUT=1 Q
35 I $Y+8>IOSL W @IOF D HED
36 W !!!,FBVNAME I FBADDCK S Y=FBVIEN D ^FBVDISP Q
37 W ?40,$$VID^FBNHEXP(FBVIEN) Q
38ASIH ;Checks to see if vet has been transferred ASIH on specified date.
39 S FBACT=$O(^FBAACNH("AG",DFN,+FBZ,FBCKDT)) I 'FBACT!(FBACT>FBJ) S FBOUT=1 Q
40 S FBIEN=$O(^FBAACNH("AG",DFN,+FBZ,FBACT,0)) I 'FBIEN S FBOUT=1 Q
41 I $P(^FBAACNH(FBIEN,0),"^",3)'="A" S FBCKDT=FBACT G ASIH
42 S FBTRAN=FBIEN F S FBTRAN=$O(^FBAACNH("AC",FBIEN,FBTRAN)) Q:FBTRAN="" Q:($P(^FBAACNH(FBTRAN,0),"^",3)="D") D
43 .S FBREC=$G(^FBAACNH(FBTRAN,0)),FBTRTYP=$P(FBREC,"^",7) Q:'FBTRTYP S FBTRDT=+FBREC
44 .I FBTRTYP<4,($P(FBTRDT,".")=FBDT) S FBOUT=1
45 .I FBTRTYP<4 I FBTRDT'>FBDT S FBOUT=1
46 .I FBTRTYP>3 I FBTRDT'>(FBDT+.99) K FBOUT
Note: See TracBrowser for help on using the repository browser.