47 lines
3.6 KiB
Mathematica
47 lines
3.6 KiB
Mathematica
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
|