Routine: DVBASCRP

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

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=""

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

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

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  Apr 23, 2025@17:56:36                                                                                                                                                                                                    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

DVBASCRP.m