- 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 Mar 13, 2025@21:04:11 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
