FBNHROS ;AISC/GRR-PRINT NURSING HOME ROSTERS ;16MAY90
;;3.5;FEE BASIS;;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
W !!,"This option will print Nursing Home Rosters.",!
S DIR(0)="Y",DIR("A")="Are you sure you want to continue",DIR("B")="No" D ^DIR K DIR G END:$D(DUOUT),H^XUS:$D(DTOUT),END:Y=0
S (VAL,VAR)="",PGM="START^FBNHROS" D ZIS^FBAAUTL G:FBPOP END
START U IO W:$E(IOST,1,2)["C-" @IOF K ^TMP($J)
N FBA,FBAAOUT,FBAD,FBCH,FBDASH,FBDFN,FBHED,FBI,FBP,FBPNAM,FBSSN,FBTD,FBV,FBVIEN,FBVNAM ;new variables here
S $P(FBDASH,"-",80)="",FBAAOUT=0
F FBDFN=0:0 S FBDFN=$O(^FBAACNH("AD",FBDFN)) Q:FBDFN'>0 S FBI=+$O(^FBAACNH("AD",FBDFN,0)) S FBI(0)=$G(^FBAACNH(FBI,0)) I FBI(0)]"" D
.S FBVIEN=$P(FBI(0),U,9),FBVNAM=$$PTR^FBUCUTL("^FBAAV(",FBVIEN),FBPNAM=$$PTR^FBUCUTL("^DPT(",FBDFN),^TMP($J,$P(FBVNAM,U)_";"_FBVIEN,$P(FBPNAM,U)_";"_FBDFN)=FBI
D HEADER
S FBV="" F S FBV=$O(^TMP($J,FBV)) Q:FBV=""!(FBAAOUT) S FBHED=1 S FBP="" F S FBP=$O(^TMP($J,FBV,FBP)) Q:FBP=""!(FBAAOUT) S FBVNAM=$P(FBV,";"),FBVIEN=$P(FBV,";",2),FBDFN=$P(FBP,";",2),FBI=+$G(^TMP($J,FBV,FBP)) D
.S FBSSN=$$SSN^FBAAUTL(FBDFN),FBCH(0)=$G(^FBAACNH(FBI,0)),FBAD=$P(FBCH(0),U),FBAD=$E(FBAD,1,7),FBA=$P(FBCH(0),U,10),FBTD=$S(FBA="":"",1:$P($G(^FBAAA(FBDFN,1,+FBA,0)),U,2))
.I $Y+4>IOSL&($E(IOST,1,2)["C-") S DIR(0)="E" D ^DIR K DIR I 'Y S FBAAOUT=1 Q
.I $Y+4>IOSL W @IOF D HEADER,HED
.D:FBHED HED
.W !?4,$P(FBP,";"),?37,FBSSN,?53,$$DATX^FBAAUTL(FBAD),?66,$$DATX^FBAAUTL(FBTD)
END W ! K DIR,DIRUT,DTOUT,DUOUT,I,PGM,VAL,VAR,Y,^TMP($J)
D CLOSE^FBAAUTL Q
HED S FBHED=0 W !!,FBVNAM,?50,$$VID^FBNHEXP(FBVIEN)
Q
W !,FBDASH Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHROS 1842 printed Sep 23, 2025@19:35:22 Page 2
FBNHROS ;AISC/GRR-PRINT NURSING HOME ROSTERS ;16MAY90
+1 ;;3.5;FEE BASIS;;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 WRITE !!,"This option will print Nursing Home Rosters.",!
+4 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to continue"
SET DIR("B")="No"
DO ^DIR
KILL DIR
if $DATA(DUOUT)
GOTO END
if $DATA(DTOUT)
GOTO H^XUS
if Y=0
GOTO END
+5 SET (VAL,VAR)=""
SET PGM="START^FBNHROS"
DO ZIS^FBAAUTL
if FBPOP
GOTO END
START USE IO
if $EXTRACT(IOST,1,2)["C-"
WRITE @IOF
KILL ^TMP($JOB)
+1 ;new variables here
NEW FBA,FBAAOUT,FBAD,FBCH,FBDASH,FBDFN,FBHED,FBI,FBP,FBPNAM,FBSSN,FBTD,FBV,FBVIEN,FBVNAM
+2 SET $PIECE(FBDASH,"-",80)=""
SET FBAAOUT=0
+3 FOR FBDFN=0:0
SET FBDFN=$ORDER(^FBAACNH("AD",FBDFN))
if FBDFN'>0
QUIT
SET FBI=+$ORDER(^FBAACNH("AD",FBDFN,0))
SET FBI(0)=$GET(^FBAACNH(FBI,0))
IF FBI(0)]""
Begin DoDot:1
+4 SET FBVIEN=$PIECE(FBI(0),U,9)
SET FBVNAM=$$PTR^FBUCUTL("^FBAAV(",FBVIEN)
SET FBPNAM=$$PTR^FBUCUTL("^DPT(",FBDFN)
SET ^TMP($JOB,$PIECE(FBVNAM,U)_";"_FBVIEN,$PIECE(FBPNAM,U)_";"_FBDFN)=FBI
End DoDot:1
+5 DO HEADER
+6 SET FBV=""
FOR
SET FBV=$ORDER(^TMP($JOB,FBV))
if FBV=""!(FBAAOUT)
QUIT
SET FBHED=1
SET FBP=""
FOR
SET FBP=$ORDER(^TMP($JOB,FBV,FBP))
if FBP=""!(FBAAOUT)
QUIT
SET FBVNAM=$PIECE(FBV,";")
SET FBVIEN=$PIECE(FBV,";",2)
SET FBDFN=$PIECE(FBP,";",2)
SET FBI=+$GET(^TMP($JOB,FBV,FBP))
Begin DoDot:1
+7 SET FBSSN=$$SSN^FBAAUTL(FBDFN)
SET FBCH(0)=$GET(^FBAACNH(FBI,0))
SET FBAD=$PIECE(FBCH(0),U)
SET FBAD=$EXTRACT(FBAD,1,7)
SET FBA=$PIECE(FBCH(0),U,10)
SET FBTD=$SELECT(FBA="":"",1:$PIECE($GET(^FBAAA(FBDFN,1,+FBA,0)),U,2))
+8 IF $Y+4>IOSL&($EXTRACT(IOST,1,2)["C-")
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET FBAAOUT=1
QUIT
+9 IF $Y+4>IOSL
WRITE @IOF
DO HEADER
DO HED
+10 if FBHED
DO HED
+11 WRITE !?4,$PIECE(FBP,";"),?37,FBSSN,?53,$$DATX^FBAAUTL(FBAD),?66,$$DATX^FBAAUTL(FBTD)
End DoDot:1
END WRITE !
KILL DIR,DIRUT,DTOUT,DUOUT,I,PGM,VAL,VAR,Y,^TMP($JOB)
+1 DO CLOSE^FBAAUTL
QUIT
HED SET FBHED=0
WRITE !!,FBVNAM,?50,$$VID^FBNHEXP(FBVIEN)
+1 QUIT
+1 WRITE !,FBDASH
QUIT
