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