- FBNHEXP ;AISC/CMR CNH WITH CONTRACT EXPIRING WITHIN DATE RANGE;10MAR93
- ;;3.5;FEE BASIS;;JAN 30, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- S %DT="AEX" D DATE^FBAAUTL K %DT G END:$G(FBPOP)
- W !,"This option will list nursing homes with contracts expiring between",!,$$DATX^FBAAUTL(BEGDATE)," and ",$$DATX^FBAAUTL(ENDDATE),".",!
- S DIR("A")="Are you sure you want to continue",DIR(0)="Y",DIR("B")="Yes" D ^DIR K DIR G END:$D(DIRUT)!(Y=0)
- S VAR="BEGDATE^ENDDATE",VAL=BEGDATE_"^"_ENDDATE,PGM="START^FBNHEXP" D ZIS^FBAAUTL G END:FBPOP
- ;
- START S Q="",$P(Q,"=",80)="=",FBAAOUT=0 U IO W:$E(IOST,1,2)["C-" @IOF D HED
- F FBV=0:0 S FBV=$O(^FBAA(161.21,"ADR",FBV)) Q:FBV'>0!(FBAAOUT) F FBDT=-(ENDDATE+.001):0 S FBDT=$O(^FBAA(161.21,"ADR",FBV,FBDT)) Q:FBDT=""!(FBDT>-BEGDATE)!(FBAAOUT) F FBI=0:0 S FBI=$O(^FBAA(161.21,"ADR",FBV,FBDT,FBI)) Q:FBI'>0!(FBAAOUT) D
- .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 HED
- .W !,$$VNAME(FBV),?47,$$VID(FBV),?58,$P(^FBAA(161.21,FBI,0),"^"),?72,$$DATX^FBAAUTL($P(^(0),"^",3))
- END I '$G(FBAAOUT),'$G(FBPOP),$E(IOST,1,2)="C-" W ! S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
- K BEGDATE,ENDDATE,FBAAOUT,FBDT,FBI,FBV,Q,X,Y
- D CLOSE^FBAAUTL
- Q
- HED W !?12,"CNH CONTRACTS EXPIRING BETWEEN ",$$DATX^FBAAUTL(BEGDATE)," AND ",$$DATX^FBAAUTL(ENDDATE)
- W !?12,$E(Q,1,52),!!!,"Vendor Name",?47,"Vendor ID",?58,"Contract #",?72,"Exp. Dt.",!,Q
- Q
- VNAME(X) ;INPUT - VENDOR IEN
- ;OUTPUTS VENDOR NAME
- I $G(X),$D(^FBAAV(X,0)) Q $P(^(0),"^")
- Q "UNKNOWN"
- ;
- VID(X) ;INPUT - VENDOR IEN
- ;OUTPUTS VENDOR ID
- I $G(X),$D(^FBAAV(X,0)) Q $P(^(0),"^",2)
- Q "UNKNOWN"
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHEXP 1704 printed Feb 18, 2025@23:25:30 Page 2
- FBNHEXP ;AISC/CMR CNH WITH CONTRACT EXPIRING WITHIN DATE RANGE;10MAR93
- +1 ;;3.5;FEE BASIS;;JAN 30, 1995
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 SET %DT="AEX"
- DO DATE^FBAAUTL
- KILL %DT
- if $GET(FBPOP)
- GOTO END
- +4 WRITE !,"This option will list nursing homes with contracts expiring between",!,$$DATX^FBAAUTL(BEGDATE)," and ",$$DATX^FBAAUTL(ENDDATE),".",!
- +5 SET DIR("A")="Are you sure you want to continue"
- SET DIR(0)="Y"
- SET DIR("B")="Yes"
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)!(Y=0)
- GOTO END
- +6 SET VAR="BEGDATE^ENDDATE"
- SET VAL=BEGDATE_"^"_ENDDATE
- SET PGM="START^FBNHEXP"
- DO ZIS^FBAAUTL
- if FBPOP
- GOTO END
- +7 ;
- START SET Q=""
- SET $PIECE(Q,"=",80)="="
- SET FBAAOUT=0
- USE IO
- if $EXTRACT(IOST,1,2)["C-"
- WRITE @IOF
- DO HED
- +1 FOR FBV=0:0
- SET FBV=$ORDER(^FBAA(161.21,"ADR",FBV))
- if FBV'>0!(FBAAOUT)
- QUIT
- FOR FBDT=-(ENDDATE+.001):0
- SET FBDT=$ORDER(^FBAA(161.21,"ADR",FBV,FBDT))
- if FBDT=""!(FBDT>-BEGDATE)!(FBAAOUT)
- QUIT
- FOR FBI=0:0
- SET FBI=$ORDER(^FBAA(161.21,"ADR",FBV,FBDT,FBI))
- if FBI'>0!(FBAAOUT)
- QUIT
- Begin DoDot:1
- +2 IF $Y+4>IOSL
- IF ($EXTRACT(IOST,1,2)["C-")
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- IF 'Y
- SET FBAAOUT=1
- QUIT
- +3 IF $Y+4>IOSL
- WRITE @IOF
- DO HED
- +4 WRITE !,$$VNAME(FBV),?47,$$VID(FBV),?58,$PIECE(^FBAA(161.21,FBI,0),"^"),?72,$$DATX^FBAAUTL($PIECE(^(0),"^",3))
- End DoDot:1
- END IF '$GET(FBAAOUT)
- IF '$GET(FBPOP)
- IF $EXTRACT(IOST,1,2)="C-"
- WRITE !
- SET DIR(0)="E"
- SET DIR("A")="Press Return to continue"
- DO ^DIR
- KILL DIR
- +1 KILL BEGDATE,ENDDATE,FBAAOUT,FBDT,FBI,FBV,Q,X,Y
- +2 DO CLOSE^FBAAUTL
- +3 QUIT
- HED WRITE !?12,"CNH CONTRACTS EXPIRING BETWEEN ",$$DATX^FBAAUTL(BEGDATE)," AND ",$$DATX^FBAAUTL(ENDDATE)
- +1 WRITE !?12,$EXTRACT(Q,1,52),!!!,"Vendor Name",?47,"Vendor ID",?58,"Contract #",?72,"Exp. Dt.",!,Q
- +2 QUIT
- VNAME(X) ;INPUT - VENDOR IEN
- +1 ;OUTPUTS VENDOR NAME
- +2 IF $GET(X)
- IF $DATA(^FBAAV(X,0))
- QUIT $PIECE(^(0),"^")
- +3 QUIT "UNKNOWN"
- +4 ;
- VID(X) ;INPUT - VENDOR IEN
- +1 ;OUTPUTS VENDOR ID
- +2 IF $GET(X)
- IF $DATA(^FBAAV(X,0))
- QUIT $PIECE(^(0),"^",2)
- +3 QUIT "UNKNOWN"