DVBAADRP ;ALB/GTS-557/THM-AMIE COMPLETE ADMISSION RPT ; 1/22/91 1:19 PM
;;2.7;AMIE;**17,42,53,108,149,185**;Apr 10, 1995;Build 18
;Per VHA Directive 2004-038, this routine should not be modified.
;
N DVBGUI
S DVBGUI=0
K ^TMP($J) G TERM
Q
;
ENBROKER(Y) ;
; Returns some info for the CAPRI GUI to display prior
; to the user running this report
N DVBGUI
S DVBGUI=1
K ^TMP($J)
D HOME^%ZIS K NOASK,QUIT1
D NOPARM^DVBAUTL2 G:$D(DVBAQUIT) KILL^DVBAUTIL
;
S Y(1)="VARO COMPLETE ADMISSION REPORT" S DTAR=^DVB(396.1,1,0),FDT(0)=$$FMTE^XLFDT(DT,"5DZ")
S HEAD="TOTAL ADMISSION REPORT",HEAD1="FOR "_$P(DTAR,U,1)_" ON "_FDT(0)
S Y(2)=HEAD1,Y(3)=""
S Y(4)="Please enter dates for search, oldest date first, most recent date last."
S Y=$P(DTAR,U,3) X ^DD("DD")
S Y(5)=""
S Y(6)="Last report was run on "_Y
Q
;
;Input: DVBADLMTR - Indicates if report should be delimited (Optional)
ENBROKE2(MSG,BDATE,EDATE,RO,RONUM,DVBADLMTR) ;
; This is the entry point to run the actual report from
; the CAPRI GUI.
N DVBHFS,DVBERR,DVBGUI,I,DVBADHDR
K ^TMP("DVBA",$J)
S DVBADLMTR=$S('+$G(DVBADLMTR):"",1:","),DVBADHDR=0
S DVBGUI=1,DVBERR=0,DVBHFS=$$HFS^DVBAB82()
S X=BDATE,Y=EDATE
; DVBA*2.7*108 - Correct next line. CAPRI GUI already adds 1 to EDATE
; S BDATE=BDATE-.5,EDATE=EDATE+.5
S BDATE=BDATE-.5,EDATE=EDATE-.5
K ^TMP($J)
D HOME^%ZIS K NOASK,QUIT1
D NOPARM^DVBAUTL2 G:$D(DVBAQUIT) KILL^DVBAUTIL
;
S HEAD="TOTAL ADMISSION REPORT",HEAD1="FOR "_$P(DTAR,U,1)_" ON "_FDT(0)
I $D(X) D
. G:X=""!(Y<0) KILL S %ZIS="AEQ" D ^%ZIS K %ZIS
D HFSOPEN^DVBAB82("DVBRP",DVBHFS,"W") I DVBERR D END^DVBAB82 Q
I POP K DVBAON2,DCHPTR,M,Y,J G KILL^DVBAUTIL
U IO
D DEQUE
D END^DVBAB82
Q
SET Q:'$D(^DPT(DA,0)) S DFN=DA D RCV^DVBAVDPT Q:CFLOC'=RONUM&(RO="Y")&(CFLOC'=0)&(CFLOC'=376)
S ^TMP($J,XCN,CFLOC,MB,DA)=MA_U_RCVAA_U_RCVPEN_U_CNUM
Q
;
PRINTB S MA=$P(DATA,U),RCVAA=$P(DATA,U,2),RCVPEN=$P(DATA,U,3),CNUM=$P(DATA,U,4),DFN=DA,QUIT1=1 D ADM^DVBAVDPT
S:ADMDT]"" ADMDT=$$FMTE^XLFDT(ADMDT,"5DZ")
S:DCHGDT]"" DCHGDT=$$FMTE^XLFDT(DCHGDT,"5DZ")
D:($G(DVBADLMTR)'="") PRINTD
D:($G(DVBADLMTR)="") PRINTND
Q
;
PRINTND ;print non-delimited admission inq report
W:(IOST?1"C-".E!($D(DVBAON2))) @IOF
I DVBGUI=0 W !!!,?(80-$L(HEAD)\2),HEAD,!,?(80-$L(HEAD1)\2),HEAD1,!!
I DVBGUI=1 W !!
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 S DVBAON2=""
I IOST?1"C-".E DO
.I ($O(^TMP($J,XCN))'=""!($O(^TMP($J,XCN,CFLOC))'=""!($O(^TMP($J,XCN,CFLOC,ADM))'=""!($O(^TMP($J,XCN,CFLOC,ADM,DA))'="")))) DO
..I DVBGUI=0 D
...W *7,!,"Press RETURN to continue or ""^"" to stop "
...R ANS:DTIME
...S:ANS=U!('$T) QUIT=1
...I '$T S DVBAQUIT=1
.I ($O(^TMP($J,XCN))=""&($O(^TMP($J,XCN,CFLOC))=""&($O(^TMP($J,XCN,CFLOC,ADM))=""&($O(^TMP($J,XCN,CFLOC,ADM,DA))="")))) DO
..I DVBGUI=0 D
...W *7,!,"Press RETURN to continue "
...R ANS:DTIME
Q
;
PRINTD ;print delimited admission inq report
;eligibility logic copied from ELIG^DVBAVDPT
N ELIG,INCMP
S ELIG=DVBAELIG,INCMP=""
I ELIG]"" S ELIG=ELIG_" ("_$S(DVBAELST="P":"Pend Ver",DVBAELST="R":"Pend Re-verif",DVBAELST="V":"Verified",1:"Not Verified")_")"
I $D(^DPT(DA,.29)) S INCMP=$S($P(^(.29),U,12)=1:"Incompetent",1:"")
I INCMP]"",ELIG]"" S ELIG=ELIG_", "_INCMP
D DEM^VADPT I $G(SSN)'="" S SSN=$P($G(VADM(2)),U,2)
D:('DVBADHDR) COLHDR
W !,""""_PNAM_""""_DVBADLMTR_$C(160)_CNUM_DVBADLMTR_CFLOC_DVBADLMTR_SSN_DVBADLMTR_ADMDT_DVBADLMTR_""""_DIAG_""""_DVBADLMTR
W DCHGDT_DVBADLMTR_""""_BEDSEC_""""_DVBADLMTR_$S(RCVAA=0:"NO",RCVAA=1:"YES",1:"Not specified")_DVBADLMTR
W $S(RCVPEN=0:"NO",RCVPEN=1:"YES",1:"Not specified")_DVBADLMTR_""""_ELIG_""""
Q
;
PRINT U IO S QUIT="" K MA,MB
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,QUIT1
D NOPARM^DVBAUTL2 G:$D(DVBAQUIT) KILL^DVBAUTIL
;
SETUP W @IOF,!,"VARO COMPLETE ADMISSION REPORT" S DTAR=^DVB(396.1,1,0),FDT(0)=$$FMTE^XLFDT(DT,"5DZ")
S HEAD="TOTAL ADMISSION REPORT",HEAD1="FOR "_$P(DTAR,U,1)_" ON "_FDT(0)
W !,HEAD1
EN1 W !!,"Please enter dates for search, oldest date first, most recent date last.",!!,"Last report was run on " S Y=$P(DTAR,U,3) X ^DD("DD") W Y,!!
D DATE^DVBAUTIL
G:X=""!(Y<0) KILL S %ZIS="AEQ" D ^%ZIS K %ZIS
I POP K DVBAON2,DCHPTR,M,Y,J G KILL^DVBAUTIL
;
QUEUE I $D(IO("Q")) S ZTRTN="DEQUE^DVBAADRP",ZTIO=ION,NOASK=1,ZTDESC="AMIE ADMISSION REPORT" F I="BDATE","EDATE","HEAD","HEAD1","RO","RONUM","FDT(0)","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="") W:(('$D(NOASK))&($G(DVBADLMTR)="")) "." 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="" I MA'>EDATE D SET
I '$D(^TMP($J)) D H 2 G KILL
.U IO
.W:($G(DVBADLMTR)="") !!,*7
.W "No data found for parameters entered.",!!
W:(($G(DVBGUI)=1)&($G(DVBADLMTR)="")) !,HEAD,!,HEAD1,!
I $D(^TMP($J)) D PRINT I $D(DVBAQUIT) K DVBAON2,DCHPTR,M,Y,J G KILL^DVBAUTIL
;
KILL ;
D ^%ZISC S X=3 K DVBAON2,DCHPTR,M,Y,J D:$D(ZTQUEUED) KILL^%ZTLOAD G FINAL^DVBAUTIL
;
DEQUE K ^TMP($J) G GO
;
COLHDR ;Column header for delimited report
W "Patient Name"_DVBADLMTR_"Claim No"_DVBADLMTR_"Claim Folder Loc"_DVBADLMTR
W "Social Sec No"_DVBADLMTR_"Admission Date"_DVBADLMTR_"Admitting Diagnosis"_DVBADLMTR
W "Discharge Date"_DVBADLMTR_"Bed Service"_DVBADLMTR_"Recv A&A?"_DVBADLMTR
W "Pension?"_DVBADLMTR_"Eligibility Data"
S DVBADHDR=1 ;set so header info only printed once
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAADRP 6237 printed Dec 13, 2024@01:40:15 Page 2
DVBAADRP ;ALB/GTS-557/THM-AMIE COMPLETE ADMISSION RPT ; 1/22/91 1:19 PM
+1 ;;2.7;AMIE;**17,42,53,108,149,185**;Apr 10, 1995;Build 18
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 NEW DVBGUI
+5 SET DVBGUI=0
+6 KILL ^TMP($JOB)
GOTO TERM
+7 QUIT
+8 ;
ENBROKER(Y) ;
+1 ; Returns some info for the CAPRI GUI to display prior
+2 ; to the user running this report
+3 NEW DVBGUI
+4 SET DVBGUI=1
+5 KILL ^TMP($JOB)
+6 DO HOME^%ZIS
KILL NOASK,QUIT1
+7 DO NOPARM^DVBAUTL2
if $DATA(DVBAQUIT)
GOTO KILL^DVBAUTIL
+8 ;
+9 SET Y(1)="VARO COMPLETE ADMISSION REPORT"
SET DTAR=^DVB(396.1,1,0)
SET FDT(0)=$$FMTE^XLFDT(DT,"5DZ")
+10 SET HEAD="TOTAL ADMISSION REPORT"
SET HEAD1="FOR "_$PIECE(DTAR,U,1)_" ON "_FDT(0)
+11 SET Y(2)=HEAD1
SET Y(3)=""
+12 SET Y(4)="Please enter dates for search, oldest date first, most recent date last."
+13 SET Y=$PIECE(DTAR,U,3)
XECUTE ^DD("DD")
+14 SET Y(5)=""
+15 SET Y(6)="Last report was run on "_Y
+16 QUIT
+17 ;
+18 ;Input: DVBADLMTR - Indicates if report should be delimited (Optional)
ENBROKE2(MSG,BDATE,EDATE,RO,RONUM,DVBADLMTR) ;
+1 ; This is the entry point to run the actual report from
+2 ; the CAPRI GUI.
+3 NEW DVBHFS,DVBERR,DVBGUI,I,DVBADHDR
+4 KILL ^TMP("DVBA",$JOB)
+5 SET DVBADLMTR=$SELECT('+$GET(DVBADLMTR):"",1:",")
SET DVBADHDR=0
+6 SET DVBGUI=1
SET DVBERR=0
SET DVBHFS=$$HFS^DVBAB82()
+7 SET X=BDATE
SET Y=EDATE
+8 ; DVBA*2.7*108 - Correct next line. CAPRI GUI already adds 1 to EDATE
+9 ; S BDATE=BDATE-.5,EDATE=EDATE+.5
+10 SET BDATE=BDATE-.5
SET EDATE=EDATE-.5
+11 KILL ^TMP($JOB)
+12 DO HOME^%ZIS
KILL NOASK,QUIT1
+13 DO NOPARM^DVBAUTL2
if $DATA(DVBAQUIT)
GOTO KILL^DVBAUTIL
+14 ;
+15 SET HEAD="TOTAL ADMISSION REPORT"
SET HEAD1="FOR "_$PIECE(DTAR,U,1)_" ON "_FDT(0)
+16 IF $DATA(X)
Begin DoDot:1
+17 if X=""!(Y<0)
GOTO KILL
SET %ZIS="AEQ"
DO ^%ZIS
KILL %ZIS
End DoDot:1
+18 DO HFSOPEN^DVBAB82("DVBRP",DVBHFS,"W")
IF DVBERR
DO END^DVBAB82
QUIT
+19 IF POP
KILL DVBAON2,DCHPTR,M,Y,J
GOTO KILL^DVBAUTIL
+20 USE IO
+21 DO DEQUE
+22 DO END^DVBAB82
+23 QUIT
SET if '$DATA(^DPT(DA,0))
QUIT
SET DFN=DA
DO RCV^DVBAVDPT
if CFLOC'=RONUM&(RO="Y")&(CFLOC'=0)&(CFLOC'=376)
QUIT
+1 SET ^TMP($JOB,XCN,CFLOC,MB,DA)=MA_U_RCVAA_U_RCVPEN_U_CNUM
+2 QUIT
+3 ;
PRINTB SET MA=$PIECE(DATA,U)
SET RCVAA=$PIECE(DATA,U,2)
SET RCVPEN=$PIECE(DATA,U,3)
SET CNUM=$PIECE(DATA,U,4)
SET DFN=DA
SET QUIT1=1
DO ADM^DVBAVDPT
+1 if ADMDT]""
SET ADMDT=$$FMTE^XLFDT(ADMDT,"5DZ")
+2 if DCHGDT]""
SET DCHGDT=$$FMTE^XLFDT(DCHGDT,"5DZ")
+3 if ($GET(DVBADLMTR)'="")
DO PRINTD
+4 if ($GET(DVBADLMTR)="")
DO PRINTND
+5 QUIT
+6 ;
PRINTND ;print non-delimited admission inq report
+1 if (IOST?1"C-".E!($DATA(DVBAON2)))
WRITE @IOF
+2 IF DVBGUI=0
WRITE !!!,?(80-$LENGTH(HEAD)\2),HEAD,!,?(80-$LENGTH(HEAD1)\2),HEAD1,!!
+3 IF DVBGUI=1
WRITE !!
+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
IF IOST'?1"C-".E
SET DVBAON2=""
+7 IF IOST?1"C-".E
Begin DoDot:1
+8 IF ($ORDER(^TMP($JOB,XCN))'=""!($ORDER(^TMP($JOB,XCN,CFLOC))'=""!($ORDER(^TMP($JOB,XCN,CFLOC,ADM))'=""!($ORDER(^TMP($JOB,XCN,CFLOC,ADM,DA))'=""))))
Begin DoDot:2
+9 IF DVBGUI=0
Begin DoDot:3
+10 WRITE *7,!,"Press RETURN to continue or ""^"" to stop "
+11 READ ANS:DTIME
+12 if ANS=U!('$TEST)
SET QUIT=1
+13 IF '$TEST
SET DVBAQUIT=1
End DoDot:3
End DoDot:2
+14 IF ($ORDER(^TMP($JOB,XCN))=""&($ORDER(^TMP($JOB,XCN,CFLOC))=""&($ORDER(^TMP($JOB,XCN,CFLOC,ADM))=""&($ORDER(^TMP($JOB,XCN,CFLOC,ADM,DA))=""))))
Begin DoDot:2
+15 IF DVBGUI=0
Begin DoDot:3
+16 WRITE *7,!,"Press RETURN to continue "
+17 READ ANS:DTIME
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
PRINTD ;print delimited admission inq report
+1 ;eligibility logic copied from ELIG^DVBAVDPT
+2 NEW ELIG,INCMP
+3 SET ELIG=DVBAELIG
SET INCMP=""
+4 IF ELIG]""
SET ELIG=ELIG_" ("_$SELECT(DVBAELST="P":"Pend Ver",DVBAELST="R":"Pend Re-verif",DVBAELST="V":"Verified",1:"Not Verified")_")"
+5 IF $DATA(^DPT(DA,.29))
SET INCMP=$SELECT($PIECE(^(.29),U,12)=1:"Incompetent",1:"")
+6 IF INCMP]""
IF ELIG]""
SET ELIG=ELIG_", "_INCMP
+7 DO DEM^VADPT
IF $GET(SSN)'=""
SET SSN=$PIECE($GET(VADM(2)),U,2)
+8 if ('DVBADHDR)
DO COLHDR
+9 WRITE !,""""_PNAM_""""_DVBADLMTR_$CHAR(160)_CNUM_DVBADLMTR_CFLOC_DVBADLMTR_SSN_DVBADLMTR_ADMDT_DVBADLMTR_""""_DIAG_""""_DVBADLMTR
+10 WRITE DCHGDT_DVBADLMTR_""""_BEDSEC_""""_DVBADLMTR_$SELECT(RCVAA=0:"NO",RCVAA=1:"YES",1:"Not specified")_DVBADLMTR
+11 WRITE $SELECT(RCVPEN=0:"NO",RCVPEN=1:"YES",1:"Not specified")_DVBADLMTR_""""_ELIG_""""
+12 QUIT
+13 ;
PRINT USE IO
SET QUIT=""
KILL MA,MB
+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,QUIT1
+1 DO NOPARM^DVBAUTL2
if $DATA(DVBAQUIT)
GOTO KILL^DVBAUTIL
+2 ;
SETUP WRITE @IOF,!,"VARO COMPLETE ADMISSION REPORT"
SET DTAR=^DVB(396.1,1,0)
SET FDT(0)=$$FMTE^XLFDT(DT,"5DZ")
+1 SET HEAD="TOTAL ADMISSION REPORT"
SET HEAD1="FOR "_$PIECE(DTAR,U,1)_" ON "_FDT(0)
+2 WRITE !,HEAD1
EN1 WRITE !!,"Please enter dates for search, oldest date first, most recent date last.",!!,"Last report was run on "
SET Y=$PIECE(DTAR,U,3)
XECUTE ^DD("DD")
WRITE Y,!!
+1 DO DATE^DVBAUTIL
+2 if X=""!(Y<0)
GOTO KILL
SET %ZIS="AEQ"
DO ^%ZIS
KILL %ZIS
+3 IF POP
KILL DVBAON2,DCHPTR,M,Y,J
GOTO KILL^DVBAUTIL
+4 ;
QUEUE IF $DATA(IO("Q"))
SET ZTRTN="DEQUE^DVBAADRP"
SET ZTIO=ION
SET NOASK=1
SET ZTDESC="AMIE ADMISSION REPORT"
FOR I="BDATE","EDATE","HEAD","HEAD1","RO","RONUM","FDT(0)","NOASK"
SET ZTSAVE(I)=""
+1 IF $DATA(IO("Q"))
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !!,"Request queued.",!!
GOTO KILL
+2 ;
GO SET MA=BDATE
FOR J=0:0
SET MA=$ORDER(^DGPM("AMV1",MA))
if $PIECE(MA,".")>EDATE!(MA="")
QUIT
if (('$DATA(NOASK))&($GET(DVBADLMTR)=""))
WRITE "."
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
IF MA'>EDATE
DO SET
+1 IF '$DATA(^TMP($JOB))
Begin DoDot:1
+2 USE IO
+3 if ($GET(DVBADLMTR)="")
WRITE !!,*7
+4 WRITE "No data found for parameters entered.",!!
End DoDot:1
HANG 2
GOTO KILL
+5 if (($GET(DVBGUI)=1)&($GET(DVBADLMTR)=""))
WRITE !,HEAD,!,HEAD1,!
+6 IF $DATA(^TMP($JOB))
DO PRINT
IF $DATA(DVBAQUIT)
KILL DVBAON2,DCHPTR,M,Y,J
GOTO KILL^DVBAUTIL
+7 ;
KILL ;
+1 DO ^%ZISC
SET X=3
KILL DVBAON2,DCHPTR,M,Y,J
if $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
GOTO FINAL^DVBAUTIL
+2 ;
DEQUE KILL ^TMP($JOB)
GOTO GO
+1 ;
COLHDR ;Column header for delimited report
+1 WRITE "Patient Name"_DVBADLMTR_"Claim No"_DVBADLMTR_"Claim Folder Loc"_DVBADLMTR
+2 WRITE "Social Sec No"_DVBADLMTR_"Admission Date"_DVBADLMTR_"Admitting Diagnosis"_DVBADLMTR
+3 WRITE "Discharge Date"_DVBADLMTR_"Bed Service"_DVBADLMTR_"Recv A&A?"_DVBADLMTR
+4 WRITE "Pension?"_DVBADLMTR_"Eligibility Data"
+5 ;set so header info only printed once
SET DVBADHDR=1
+6 QUIT
