FBNHROS.m

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

HEADER W !?20,"Nursing Home Roster - ",$$PDATE^FBUCUTL2(DT),!?19,$E(FBDASH,1,41),!,"VENDOR NAME",?50,"VENDOR ID",!,?4,"VETERAN NAME",?37,"VETERAN ID",?53,"ADMIT DT",?65,"AUTH TO DATE",!

 W !,FBDASH Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---FBNHROS   1842     printed  Apr 09, 2024@21:03:19                                                                                                                                                                                                     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 

HEADER     WRITE !?20,"Nursing Home Roster - ",$$PDATE^FBUCUTL2(DT),!?19,$EXTRACT(FBDASH,1,41),!,"VENDOR NAME",?50,"VENDOR ID",!,?4,"VETERAN NAME",?37,"VETERAN ID",?53,"ADMIT DT",?65,"AUTH TO DATE",!

 +1        WRITE !,FBDASH

           QUIT