DVBASCRP ;ALB/GTS-557/THM-SC 7131 ADMISSION RPT ;12/3/90 14:58
;;2.7;AMIE;;Apr 10, 1995
K ^TMP($J) G TERM
SET Q:'$D(^DPT(DA,0)) S DFN=DA,DVBASC="" D SC^DVBAVDPT Q:DVBASC'="Y" Q:CFLOC'=RONUM&(RO="Y")&(CFLOC'=0)&(CFLOC'=376) S ^TMP($J,XCN,CFLOC,MB,DA)=MA
Q
;
PRINTB S ADMDT=$P(DATA,U),DFN=DA D ADM^DVBAVDPT
W:(IOST?1"C-".E)!($D(DVBAON2)) @IOF
W !!!,?(80-$L(HEAD)\2),HEAD,!,?(80-$L(HEAD1)\2),HEAD1,!!
S:ADMDT]"" ADMDT=$E(ADMDT,4,5)_"/"_$E(ADMDT,6,7)_"/"_$E(ADMDT,2,3) S:DCHGDT]"" DCHGDT=$E(DCHGDT,4,5)_"/"_$E(DCHGDT,6,7)_"/"_$E(DCHGDT,2,3)
W ?10,"Patient Name:",?26,PNAM,!!,?14,"Claim No:",?26,CNUM,!,?6,"Claim Folder Loc:",?26,CFLOC,!,?9,"Social Sec No:",?26,SSN,!,?8,"Admission Date:",?26,ADMDT,!,?3,"Admitting Diagnosis:",?26,DIAG,!
W ?8,"Discharge Date:",?26,DCHGDT,!,?11,"Bed Service:",?26,BEDSEC,!,?13,"Recv A&A?:",?26,$S(RCVAA=0:"NO",RCVAA=1:"YES",1:"Not specified"),!
W ?14,"Pension?:",?26,$S(RCVPEN=0:"NO",RCVPEN=1:"YES",1:"Not specified"),! D ELIG^DVBAVDPT
I IOST?1"C-".E W *7,!,"Press RETURN to continue or ""^"" to stop " R ANS:DTIME S:ANS=U!('$T) QUIT=1 I '$T S DVBAQUIT=1
S DVBAON2=""
Q
;
PRINT U IO K MA S QUIT=""
S XCN="" F M=0:0 S XCN=$O(^TMP($J,XCN)) Q:XCN=""!(QUIT=1) S CFLOC="" F J=0:0 S CFLOC=$O(^TMP($J,XCN,CFLOC)) Q:CFLOC=""!(QUIT=1) D PRINT1
Q
PRINT1 S ADM="" F K=0:0 S ADM=$O(^TMP($J,XCN,CFLOC,ADM)) Q:ADM=""!(QUIT=1) S DA="" F L=0:0 S DA=$O(^TMP($J,XCN,CFLOC,ADM,DA)) Q:DA=""!(QUIT=1) S DATA=^(DA) D PRINTB
Q
;
TERM D HOME^%ZIS K NOASK
;
W @IOF,!,"VARO SERVICE-CONNECTED ADMISSION REPORT" D NOPARM^DVBAUTL2 G:$D(DVBAQUIT) KILL^DVBAUTIL S DTAR=^DVB(396.1,1,0),FDT(0)=$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)
S HEAD="SERVICE-CONNECTED ADMISSION REPORT",HEAD1="FOR "_$P(DTAR,U,1)_" ON "_FDT(0)
W !,HEAD1
W !!,"Please enter dates for search, oldest date first, most recent date last.",!!,"Last report was run on " S Y=$P(DTAR,U,8) X ^DD("DD") W Y,!!
D DATE^DVBAUTIL
G:X=""!(Y<0) KILL
S %ZIS="Q" D ^%ZIS K %ZIS G:POP KILL^DVBAUTIL
;
I $D(IO("Q")) S ZTRTN="DEQUE^DVBASCRP",ZTIO=ION,NOASK=1,ZTDESC="AMIE SC ADMISSION REPORT" F I="FDT(0)","HEAD","HEAD1","BDATE","EDATE","TYPE","RO","RONUM","NOASK" S ZTSAVE(I)=""
I $D(IO("Q")) D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued.",!! G KILL
;
GO S MA=BDATE F J=0:0 S MA=$O(^DGPM("AMV1",MA)) Q:$P(MA,".")>EDATE!(MA="") F DA=0:0 S DA=$O(^DGPM("AMV1",MA,DA)) Q:DA="" F MB=0:0 S MB=$O(^DGPM("AMV1",MA,DA,MB)) Q:MB="" D SET W:'$D(NOASK) "."
I '$D(^TMP($J)) U IO W !!,*7,"No data found for parameters entered.",!! H 2 G KILL
D PRINT I $D(DVBAQUIT) K DVBAON2 D:$D(ZTQUEUED) KILL^%ZTLOAD G KILL^DVBAUTIL
;
KILL D:$D(ZTQUEUED) KILL^%ZTLOAD D ^%ZISC S X=8 K DVBAON2 G FINAL^DVBAUTIL
;
DEQUE K ^TMP($J) G GO
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBASCRP 2742 printed Sep 23, 2025@19:18:09 Page 2
DVBASCRP ;ALB/GTS-557/THM-SC 7131 ADMISSION RPT ;12/3/90 14:58
+1 ;;2.7;AMIE;;Apr 10, 1995
+2 KILL ^TMP($JOB)
GOTO TERM
SET if '$DATA(^DPT(DA,0))
QUIT
SET DFN=DA
SET DVBASC=""
DO SC^DVBAVDPT
if DVBASC'="Y"
QUIT
if CFLOC'=RONUM&(RO="Y")&(CFLOC'=0)&(CFLOC'=376)
QUIT
SET ^TMP($JOB,XCN,CFLOC,MB,DA)=MA
+1 QUIT
+2 ;
PRINTB SET ADMDT=$PIECE(DATA,U)
SET DFN=DA
DO ADM^DVBAVDPT
+1 if (IOST?1"C-".E)!($DATA(DVBAON2))
WRITE @IOF
+2 WRITE !!!,?(80-$LENGTH(HEAD)\2),HEAD,!,?(80-$LENGTH(HEAD1)\2),HEAD1,!!
+3 if ADMDT]""
SET ADMDT=$EXTRACT(ADMDT,4,5)_"/"_$EXTRACT(ADMDT,6,7)_"/"_$EXTRACT(ADMDT,2,3)
if DCHGDT]""
SET DCHGDT=$EXTRACT(DCHGDT,4,5)_"/"_$EXTRACT(DCHGDT,6,7)_"/"_$EXTRACT(DCHGDT,2,3)
+4 WRITE ?10,"Patient Name:",?26,PNAM,!!,?14,"Claim No:",?26,CNUM,!,?6,"Claim Folder Loc:",?26,CFLOC,!,?9,"Social Sec No:",?26,SSN,!,?8,"Admission Date:",?26,ADMDT,!,?3,"Admitting Diagnosis:",?26,DIAG,!
+5 WRITE ?8,"Discharge Date:",?26,DCHGDT,!,?11,"Bed Service:",?26,BEDSEC,!,?13,"Recv A&A?:",?26,$SELECT(RCVAA=0:"NO",RCVAA=1:"YES",1:"Not specified"),!
+6 WRITE ?14,"Pension?:",?26,$SELECT(RCVPEN=0:"NO",RCVPEN=1:"YES",1:"Not specified"),!
DO ELIG^DVBAVDPT
+7 IF IOST?1"C-".E
WRITE *7,!,"Press RETURN to continue or ""^"" to stop "
READ ANS:DTIME
if ANS=U!('$TEST)
SET QUIT=1
IF '$TEST
SET DVBAQUIT=1
+8 SET DVBAON2=""
+9 QUIT
+10 ;
PRINT USE IO
KILL MA
SET QUIT=""
+1 SET XCN=""
FOR M=0:0
SET XCN=$ORDER(^TMP($JOB,XCN))
if XCN=""!(QUIT=1)
QUIT
SET CFLOC=""
FOR J=0:0
SET CFLOC=$ORDER(^TMP($JOB,XCN,CFLOC))
if CFLOC=""!(QUIT=1)
QUIT
DO PRINT1
+2 QUIT
PRINT1 SET ADM=""
FOR K=0:0
SET ADM=$ORDER(^TMP($JOB,XCN,CFLOC,ADM))
if ADM=""!(QUIT=1)
QUIT
SET DA=""
FOR L=0:0
SET DA=$ORDER(^TMP($JOB,XCN,CFLOC,ADM,DA))
if DA=""!(QUIT=1)
QUIT
SET DATA=^(DA)
DO PRINTB
+1 QUIT
+2 ;
TERM DO HOME^%ZIS
KILL NOASK
+1 ;
+2 WRITE @IOF,!,"VARO SERVICE-CONNECTED ADMISSION REPORT"
DO NOPARM^DVBAUTL2
if $DATA(DVBAQUIT)
GOTO KILL^DVBAUTIL
SET DTAR=^DVB(396.1,1,0)
SET FDT(0)=$EXTRACT(DT,4,5)_"-"_$EXTRACT(DT,6,7)_"-"_$EXTRACT(DT,2,3)
+3 SET HEAD="SERVICE-CONNECTED ADMISSION REPORT"
SET HEAD1="FOR "_$PIECE(DTAR,U,1)_" ON "_FDT(0)
+4 WRITE !,HEAD1
+5 WRITE !!,"Please enter dates for search, oldest date first, most recent date last.",!!,"Last report was run on "
SET Y=$PIECE(DTAR,U,8)
XECUTE ^DD("DD")
WRITE Y,!!
+6 DO DATE^DVBAUTIL
+7 if X=""!(Y<0)
GOTO KILL
+8 SET %ZIS="Q"
DO ^%ZIS
KILL %ZIS
if POP
GOTO KILL^DVBAUTIL
+9 ;
+10 IF $DATA(IO("Q"))
SET ZTRTN="DEQUE^DVBASCRP"
SET ZTIO=ION
SET NOASK=1
SET ZTDESC="AMIE SC ADMISSION REPORT"
FOR I="FDT(0)","HEAD","HEAD1","BDATE","EDATE","TYPE","RO","RONUM","NOASK"
SET ZTSAVE(I)=""
+11 IF $DATA(IO("Q"))
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !!,"Request queued.",!!
GOTO KILL
+12 ;
GO SET MA=BDATE
FOR J=0:0
SET MA=$ORDER(^DGPM("AMV1",MA))
if $PIECE(MA,".")>EDATE!(MA="")
QUIT
FOR DA=0:0
SET DA=$ORDER(^DGPM("AMV1",MA,DA))
if DA=""
QUIT
FOR MB=0:0
SET MB=$ORDER(^DGPM("AMV1",MA,DA,MB))
if MB=""
QUIT
DO SET
if '$DATA(NOASK)
WRITE "."
+1 IF '$DATA(^TMP($JOB))
USE IO
WRITE !!,*7,"No data found for parameters entered.",!!
HANG 2
GOTO KILL
+2 DO PRINT
IF $DATA(DVBAQUIT)
KILL DVBAON2
if $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
GOTO KILL^DVBAUTIL
+3 ;
KILL if $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
DO ^%ZISC
SET X=8
KILL DVBAON2
GOTO FINAL^DVBAUTIL
+1 ;
DEQUE KILL ^TMP($JOB)
GOTO GO
