- FBNHAMIE ;AISC/CMR-CNH Admission/Discharge Output ;4/28/93 11:04
- ;;3.5;FEE BASIS;;JAN 30, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- D DATE^FBAAUTL Q:FBPOP
- S VAR="BEGDATE^ENDDATE",VAL=BEGDATE_"^"_ENDDATE,PGM="START^FBNHAMIE" D ZIS^FBAAUTL G END:FBPOP
- START S FBHD="=",$P(FBHD,"=",80)="=",FBUL="-",$P(FBUL,"-",29)="-",FBAAOUT=0 U IO W:$E(IOST,1,2)["C-" @IOF D HED
- F FBDT=BEGDATE-.001:0 S FBDT=$O(^FBAACNH("B",FBDT)) Q:'FBDT!(FBDT>(ENDDATE+.9999))!(FBAAOUT) F FBIEN=0:0 S FBIEN=$O(^FBAACNH("B",FBDT,FBIEN)) Q:'FBIEN!(FBAAOUT) S FB(0)=$G(^FBAACNH(+FBIEN,0)) I FB(0)]"" D
- .S (FBTP,FB("TP"))="",FBTYPE=$S($P(FB(0),"^",3)="A":"ADMISSION",$P(FB(0),"^",3)="D":"DISCHARGE",1:0) Q:FBTYPE=0 D Q:FBAAOUT
- ..I $E(FBTYPE)="A" S FBTP=$P(FB(0),"^",6),FB("TP")=$S(FBTP=4:"ALL OTHER",FBTP=3:"FROM ASIH <15 DAYS",FBTP=1:"AFTER RE-HOSPITALIZATION >15 DAYS",FBTP=2:"TRANSFER FROM OTHER CNH",1:"")
- ..I $E(FBTYPE)="D" S FBTP=$P(FB(0),"^",8),FB("TP")=$S(FBTP=1:"REGULAR",FBTP=2:"DEATH",FBTP=3:"TRANSFER FROM OTHER CNH",FBTP=4:"ASIH",FBTP=5:"DEATH WHILE ASIH",FBTP=6:"REGULAR - PRIVATE PAY",1:"")
- ..S DFN=$P(FB(0),"^",2) Q:'$G(DFN) S FBNAME=$$NAME^FBCHREQ2(DFN),FBID=$$SSN^FBAAUTL(DFN),FTP=+$P(FB(0),"^",9)
- ..S FBVEN=$G(^FBAAV(FTP,0)),FBVNAME=$P(FBVEN,"^"),FBVID=$P(FBVEN,"^",2),FBVSTR=$P(FBVEN,"^",3),FBVCITY=$P(FBVEN,"^",4),FBVST=$P($G(^DIC(5,+$P(FBVEN,"^",5),0)),"^"),FBVZIP=$P(FBVEN,"^",6)
- ..S FBPHONE=$P($G(^FBAAV(FTP,1)),U),FBPHONE=$S(FBPHONE="":"Not entered",1:FBPHONE)
- ..D ELIG^VADPT,PRINT
- END ;
- K BEGDATE,ENDDATE,FBDT,FBAAOUT,FBIEN,FB,DFN,FBPHONE,FBNAME,FBID,FBPSA,FTP,FBVEN,FBVNAME,FBVID,FBVSTR,FBVCITY,FBVST,FBVZIP,FBHD,FBTYPE,FBUL,VAEL,VAERR,FBTP
- D CLOSE^FBAAUTL Q
- PRINT ;
- I $E(IOST,1,2)["C-",$Y+8>IOSL S DIR(0)="E" D ^DIR K DIR I 'Y S FBAAOUT=1 Q
- I $Y+8>IOSL W @IOF D HED
- W !!,FBNAME,?32,FBID,?48,$P(VAEL(1),"^",2),!?3,FBTYPE," DATE: ",$$DATX^FBAAUTL(FBDT),?36,FBTYPE," TYPE: ",$E(FB("TP"),1,28)
- I $G(FTP) W !?10,FBVNAME,?42,FBVID,!?10,FBVSTR,!?10,FBVCITY," ",FBVST," ",FBVZIP,!?10,"Phone #: ",FBPHONE
- Q
- HED ;
- W !?22,"CNH ADMISSIONS AND DISCHARGES",!?24,$$DATX^FBAAUTL(BEGDATE)," THROUGH ",$$DATX^FBAAUTL(ENDDATE),!?22,FBUL,!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHAMIE 2201 printed Mar 13, 2025@21:03:38 Page 2
- FBNHAMIE ;AISC/CMR-CNH Admission/Discharge Output ;4/28/93 11:04
- +1 ;;3.5;FEE BASIS;;JAN 30, 1995
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 DO DATE^FBAAUTL
- if FBPOP
- QUIT
- +4 SET VAR="BEGDATE^ENDDATE"
- SET VAL=BEGDATE_"^"_ENDDATE
- SET PGM="START^FBNHAMIE"
- DO ZIS^FBAAUTL
- if FBPOP
- GOTO END
- START SET FBHD="="
- SET $PIECE(FBHD,"=",80)="="
- SET FBUL="-"
- SET $PIECE(FBUL,"-",29)="-"
- SET FBAAOUT=0
- USE IO
- if $EXTRACT(IOST,1,2)["C-"
- WRITE @IOF
- DO HED
- +1 FOR FBDT=BEGDATE-.001:0
- SET FBDT=$ORDER(^FBAACNH("B",FBDT))
- if 'FBDT!(FBDT>(ENDDATE+.9999))!(FBAAOUT)
- QUIT
- FOR FBIEN=0:0
- SET FBIEN=$ORDER(^FBAACNH("B",FBDT,FBIEN))
- if 'FBIEN!(FBAAOUT)
- QUIT
- SET FB(0)=$GET(^FBAACNH(+FBIEN,0))
- IF FB(0)]""
- Begin DoDot:1
- +2 SET (FBTP,FB("TP"))=""
- SET FBTYPE=$SELECT($PIECE(FB(0),"^",3)="A":"ADMISSION",$PIECE(FB(0),"^",3)="D":"DISCHARGE",1:0)
- if FBTYPE=0
- QUIT
- Begin DoDot:2
- +3 IF $EXTRACT(FBTYPE)="A"
- SET FBTP=$PIECE(FB(0),"^",6)
- SET FB("TP")=$SELECT(FBTP=4:"ALL OTHER",FBTP=3:"FROM ASIH <15 DAYS",FBTP=1:"AFTER RE-HOSPITALIZATION >15 DAYS",FBTP=2:"TRANSFER FROM OTHER CNH",1:"")
- +4 IF $EXTRACT(FBTYPE)="D"
- SET FBTP=$PIECE(FB(0),"^",8)
- SET FB("TP")=$SELECT(FBTP=1:"REGULAR",FBTP=2:"DEATH",FBTP=3:"TRANSFER FROM OTHER CNH",FBTP=4:"ASIH",FBTP=5:"DEATH WHILE ASIH",FBTP=6:"REGULAR - PRIVATE PAY",1:"")
- +5 SET DFN=$PIECE(FB(0),"^",2)
- if '$GET(DFN)
- QUIT
- SET FBNAME=$$NAME^FBCHREQ2(DFN)
- SET FBID=$$SSN^FBAAUTL(DFN)
- SET FTP=+$PIECE(FB(0),"^",9)
- +6 SET FBVEN=$GET(^FBAAV(FTP,0))
- SET FBVNAME=$PIECE(FBVEN,"^")
- SET FBVID=$PIECE(FBVEN,"^",2)
- SET FBVSTR=$PIECE(FBVEN,"^",3)
- SET FBVCITY=$PIECE(FBVEN,"^",4)
- SET FBVST=$PIECE($GET(^DIC(5,+$PIECE(FBVEN,"^",5),0)),"^")
- SET FBVZIP=$PIECE(FBVEN,"^",6)
- +7 SET FBPHONE=$PIECE($GET(^FBAAV(FTP,1)),U)
- SET FBPHONE=$SELECT(FBPHONE="":"Not entered",1:FBPHONE)
- +8 DO ELIG^VADPT
- DO PRINT
- End DoDot:2
- if FBAAOUT
- QUIT
- End DoDot:1
- END ;
- +1 KILL BEGDATE,ENDDATE,FBDT,FBAAOUT,FBIEN,FB,DFN,FBPHONE,FBNAME,FBID,FBPSA,FTP,FBVEN,FBVNAME,FBVID,FBVSTR,FBVCITY,FBVST,FBVZIP,FBHD,FBTYPE,FBUL,VAEL,VAERR,FBTP
- +2 DO CLOSE^FBAAUTL
- QUIT
- PRINT ;
- +1 IF $EXTRACT(IOST,1,2)["C-"
- IF $Y+8>IOSL
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- IF 'Y
- SET FBAAOUT=1
- QUIT
- +2 IF $Y+8>IOSL
- WRITE @IOF
- DO HED
- +3 WRITE !!,FBNAME,?32,FBID,?48,$PIECE(VAEL(1),"^",2),!?3,FBTYPE," DATE: ",$$DATX^FBAAUTL(FBDT),?36,FBTYPE," TYPE: ",$EXTRACT(FB("TP"),1,28)
- +4 IF $GET(FTP)
- WRITE !?10,FBVNAME,?42,FBVID,!?10,FBVSTR,!?10,FBVCITY," ",FBVST," ",FBVZIP,!?10,"Phone #: ",FBPHONE
- +5 QUIT
- HED ;
- +1 WRITE !?22,"CNH ADMISSIONS AND DISCHARGES",!?24,$$DATX^FBAAUTL(BEGDATE)," THROUGH ",$$DATX^FBAAUTL(ENDDATE),!?22,FBUL,!
- +2 QUIT
