- FBNHAMI2 ;AISC/CMR-CNH STAYS IN EXCESS OF 90 DAYS ;1DEC00
- ;;3.5;FEE BASIS;**25**;JAN 30, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- W !!,"Use of this option will provide you with all 'ACTIVE' stays that are in excess",!,"of 90 days. The active stays are as of the date you choose.",!
- S %DT="APEX",%DT("A")="Enter Effective Date : " D ^%DT G END:Y<0 S FBDT=Y
- S VAR="FBDT",VAL=FBDT,PGM="START^FBNHAMI2" D ZIS^FBAAUTL G END:FBPOP
- START K ^TMP($J,"FBSTAY") S FBHD="=",$P(FBHD,"=",80)="=",FBUL="-",$P(FBUL,"-",37)="-" U IO W:$E(IOST,1,2)["C-" @IOF D HED
- S (FBADM,FBASSOC)=0
- F S FBADM=$O(^FBAACNH("AC",FBADM)) Q:'FBADM S FBCHK=0 D I FBCHK=0 D SET
- .F S FBASSOC=$O(^FBAACNH("AC",FBADM,FBASSOC)) Q:'FBASSOC D
- ..Q:FBADM=FBASSOC
- ..S FBI=$G(^FBAACNH(FBASSOC,0)),FBTYPE=$P(FBI,"^",3) Q:FBTYPE'="D" S FBDDT=$P(FBI,"^") I FBDDT'>FBDT S FBCHK=1
- S FBNAME=""
- F S FBNAME=$O(^TMP($J,"FBSTAY",FBNAME)) Q:FBNAME']""!($G(FBAAOUT)) S DFN=0 F S DFN=$O(^TMP($J,"FBSTAY",FBNAME,DFN)) Q:'DFN!($G(FBAAOUT)) D
- .S FBI=^TMP($J,"FBSTAY",FBNAME,DFN),FBID=$P(FBI,"^"),FBADT=$P(FBI,"^",2),FBVNAME=$P(FBI,"^",3),FBLOS=$P(FBI,"^",4) D PRINT
- G END:$G(FBAAOUT)
- W !!?5,"***LOS = Length of Stay as of ",$$DATX^FBAAUTL(FBDT)
- I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR
- END ;
- K %DT,FBDT,FBAAOUT,DFN,FBNAME,FBID,FBVNAME,FBHD,FBTYPE,FBUL,VAR,VAL,PGM,FBPOP,FBADM,FBASSOC,FBCHK,FBI,FBDDT,FBADT,FBLOS,^TMP($J,"FBSTAY"),FBMS,VA,VADM
- D CLOSE^FBAAUTL
- Q
- SET ;SETS UP TMP GLOBAL
- S FBADT=+^FBAACNH(FBADM,0)
- S FBLOS=$$DTC^FBUCUTL(FBDT,FBADT)
- Q:FBLOS<90
- S FBI=$G(^FBAACNH(FBADM,0)),DFN=$P(FBI,"^",2) Q:'$G(DFN) S FBNAME=$$NAME^FBCHREQ2(DFN),FBID=$$SSN^FBAAUTL(DFN),FBVNAME=$P($G(^FBAAV($P(FBI,"^",9),0)),"^")
- S ^TMP($J,"FBSTAY",FBNAME,DFN)=FBID_"^"_FBADT_"^"_FBVNAME_"^"_FBLOS_"^"_DFN
- K FBNAME,FBID,FBVNAME,FBLOS,DFN Q
- PRINT ;
- I $E(IOST,1,2)["C-",$Y+2>IOSL S DIR(0)="E" D ^DIR K DIR I 'Y S FBAAOUT=1 Q
- I $Y+2>IOSL W @IOF D HED
- W !,$E(FBNAME,1,15),?18,FBID
- D DEM^VADPT S FBMS=$E($P(VADM(10),"^",2),1) K VA,VADM
- W ?32,FBMS,?35,$$DATX^FBAAUTL($E(FBADT,1,7)),?45,$J(FBLOS,6),?53,$E(FBVNAME,1,27)
- Q
- HED ;
- W !?22,"ACTIVE CNH STAYS IN EXCESS OF 90 DAYS",!?33,"AS OF ",$$DATX^FBAAUTL(FBDT),!?22,FBUL,!!
- W ?28,"MARITAL",!,"VETERAN",?20,"Pt. ID",?30,"ST.",?35,"ADM. DATE",?48,"LOS",?60,"VENDOR",!,FBHD
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHAMI2 2355 printed Jan 18, 2025@02:59:55 Page 2
- FBNHAMI2 ;AISC/CMR-CNH STAYS IN EXCESS OF 90 DAYS ;1DEC00
- +1 ;;3.5;FEE BASIS;**25**;JAN 30, 1995
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 WRITE !!,"Use of this option will provide you with all 'ACTIVE' stays that are in excess",!,"of 90 days. The active stays are as of the date you choose.",!
- +4 SET %DT="APEX"
- SET %DT("A")="Enter Effective Date : "
- DO ^%DT
- if Y<0
- GOTO END
- SET FBDT=Y
- +5 SET VAR="FBDT"
- SET VAL=FBDT
- SET PGM="START^FBNHAMI2"
- DO ZIS^FBAAUTL
- if FBPOP
- GOTO END
- START KILL ^TMP($JOB,"FBSTAY")
- SET FBHD="="
- SET $PIECE(FBHD,"=",80)="="
- SET FBUL="-"
- SET $PIECE(FBUL,"-",37)="-"
- USE IO
- if $EXTRACT(IOST,1,2)["C-"
- WRITE @IOF
- DO HED
- +1 SET (FBADM,FBASSOC)=0
- +2 FOR
- SET FBADM=$ORDER(^FBAACNH("AC",FBADM))
- if 'FBADM
- QUIT
- SET FBCHK=0
- Begin DoDot:1
- +3 FOR
- SET FBASSOC=$ORDER(^FBAACNH("AC",FBADM,FBASSOC))
- if 'FBASSOC
- QUIT
- Begin DoDot:2
- +4 if FBADM=FBASSOC
- QUIT
- +5 SET FBI=$GET(^FBAACNH(FBASSOC,0))
- SET FBTYPE=$PIECE(FBI,"^",3)
- if FBTYPE'="D"
- QUIT
- SET FBDDT=$PIECE(FBI,"^")
- IF FBDDT'>FBDT
- SET FBCHK=1
- End DoDot:2
- End DoDot:1
- IF FBCHK=0
- DO SET
- +6 SET FBNAME=""
- +7 FOR
- SET FBNAME=$ORDER(^TMP($JOB,"FBSTAY",FBNAME))
- if FBNAME']""!($GET(FBAAOUT))
- QUIT
- SET DFN=0
- FOR
- SET DFN=$ORDER(^TMP($JOB,"FBSTAY",FBNAME,DFN))
- if 'DFN!($GET(FBAAOUT))
- QUIT
- Begin DoDot:1
- +8 SET FBI=^TMP($JOB,"FBSTAY",FBNAME,DFN)
- SET FBID=$PIECE(FBI,"^")
- SET FBADT=$PIECE(FBI,"^",2)
- SET FBVNAME=$PIECE(FBI,"^",3)
- SET FBLOS=$PIECE(FBI,"^",4)
- DO PRINT
- End DoDot:1
- +9 if $GET(FBAAOUT)
- GOTO END
- +10 WRITE !!?5,"***LOS = Length of Stay as of ",$$DATX^FBAAUTL(FBDT)
- +11 IF $EXTRACT(IOST,1,2)="C-"
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- END ;
- +1 KILL %DT,FBDT,FBAAOUT,DFN,FBNAME,FBID,FBVNAME,FBHD,FBTYPE,FBUL,VAR,VAL,PGM,FBPOP,FBADM,FBASSOC,FBCHK,FBI,FBDDT,FBADT,FBLOS,^TMP($JOB,"FBSTAY"),FBMS,VA,VADM
- +2 DO CLOSE^FBAAUTL
- +3 QUIT
- SET ;SETS UP TMP GLOBAL
- +1 SET FBADT=+^FBAACNH(FBADM,0)
- +2 SET FBLOS=$$DTC^FBUCUTL(FBDT,FBADT)
- +3 if FBLOS<90
- QUIT
- +4 SET FBI=$GET(^FBAACNH(FBADM,0))
- SET DFN=$PIECE(FBI,"^",2)
- if '$GET(DFN)
- QUIT
- SET FBNAME=$$NAME^FBCHREQ2(DFN)
- SET FBID=$$SSN^FBAAUTL(DFN)
- SET FBVNAME=$PIECE($GET(^FBAAV($PIECE(FBI,"^",9),0)),"^")
- +5 SET ^TMP($JOB,"FBSTAY",FBNAME,DFN)=FBID_"^"_FBADT_"^"_FBVNAME_"^"_FBLOS_"^"_DFN
- +6 KILL FBNAME,FBID,FBVNAME,FBLOS,DFN
- QUIT
- PRINT ;
- +1 IF $EXTRACT(IOST,1,2)["C-"
- IF $Y+2>IOSL
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- IF 'Y
- SET FBAAOUT=1
- QUIT
- +2 IF $Y+2>IOSL
- WRITE @IOF
- DO HED
- +3 WRITE !,$EXTRACT(FBNAME,1,15),?18,FBID
- +4 DO DEM^VADPT
- SET FBMS=$EXTRACT($PIECE(VADM(10),"^",2),1)
- KILL VA,VADM
- +5 WRITE ?32,FBMS,?35,$$DATX^FBAAUTL($EXTRACT(FBADT,1,7)),?45,$JUSTIFY(FBLOS,6),?53,$EXTRACT(FBVNAME,1,27)
- +6 QUIT
- HED ;
- +1 WRITE !?22,"ACTIVE CNH STAYS IN EXCESS OF 90 DAYS",!?33,"AS OF ",$$DATX^FBAAUTL(FBDT),!?22,FBUL,!!
- +2 WRITE ?28,"MARITAL",!,"VETERAN",?20,"Pt. ID",?30,"ST.",?35,"ADM. DATE",?48,"LOS",?60,"VENDOR",!,FBHD
- +3 QUIT