Routine: DVBADSCK

DVBADSCK ;ALB/GTS-557/THM-DISCHARGE CHECKER ;21 JUL 89

 ;;2.7;AMIE;**15,14,24,32**;Apr 10, 1995

 S DVBAMAN=""

 D NOPARM^DVBAUTL2 G:$D(DVBAQUIT) KILL

 S HD="MANUAL 7132 PROCESSING" D HOME^%ZIS K ^TMP($J)

DATE S %DT(0)=-DT,%DT="AE",%DT("A")="Enter BEGINNING date: "

 W @IOF,!?(IOM-$L(HD)\2),HD,!!!

 D ^%DT G:Y<0 KILL S (BDATE,BDATE1)=Y,BDATE=BDATE-.1

 S %DT("A")="     and ENDING date: ",%DT="AE" D ^%DT G:Y<0 DATE S (EDATE1,EDATE)=Y,EDATE=EDATE+.5

 I EDATE<BDATE W *7,!!,"Invalid date sequence." H 3 G DATE

 K %DT S Y=DT X ^DD("DD") S FDT(0)=Y

 W !! S %ZIS="AEQ",%ZIS("A")="Enter output device: " D ^%ZIS K %ZIS G:POP KILL

 I $D(IO("Q")) S ZTRTN="DATA^DVBADSCK",ZTIO=ION,NOASK=1,ZTDESC="AMIE Discharge Checker" F I="BDATE*","EDATE*","FDT(0)","HD","NOASK","DVBAMAN" S ZTSAVE(I)=""

 I $D(IO("Q")) D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued.",! G KILL

 G DATA

ZTM D NOPARM^DVBAUTL2 G:$D(DVBAQUIT) KILL

 I '$D(DT) S X="T" D ^%DT S DT=Y

 S Y=DT X ^DD("DD") S FDT(0)=Y

 K ^TMP($J) S X="T-1" D ^%DT Q:Y<0  S (BDATE,BDATE1)=Y,BDATE=Y-.1,(EDATE1,EDATE)=Y,EDATE=Y+.5 G DATA

CHK ;* Find the IFN of the 7131 which matches the admission date (If a 7131

 ;*  exists).

 F XDA=0:0 S XDA=$O(^DVB(396,"B",DFN,XDA)) Q:XDA=""  I $P($G(^DVB(396,XDA,0)),U,4)=ADMDT&($P($G(^DVB(396,XDA,2)),U,10)="A") Q

 QUIT

SET ;* Set up TMP global of admissions for discharges within range

 S DFN=DA,VAINDT=$S($D(^DGPM(+MB,0)):$P(^(0),U,1),1:""),VAINDT=VAINDT-.000002,VA200="" D INP^VADPT K VA200 S ADMDT=$P(VAIN(7),U,1),ADMNUM=VAIN(1)

 ;I ADMDT]"" S ADMDT=$P(ADMDT,".",1)

 Q:ADMDT=""  S ^TMP($J,ADMDT,+ADMNUM,DA)=""

SET1 ;* Get the discharge type and execute CREATE and CREAT1 as needed

 S DCHPTR=$P(^DGPM(LADM,0),U,17),TDIS=$S($D(^DGPM(+DCHPTR,0)):$P(^(0),U,18),1:"") I TDIS="" S TDIS="Unknown discharge type"

 S:'$D(^DG(405.2,+TDIS,0)) TDIS="Unknown discharge type" I $D(^(0)) S TDIS=$S($P(^DG(405.2,+TDIS,0),U,1)]"":$P(^(0),U,1),1:"Unknown discharge type")

 I XDA]"",$D(^DVB(396,XDA,0)) D CREATE Q

 I TDIS["DEATH"!(TDIS["TO CNH") D CREAT1

LOOK ;* Loop through Admission Date TMP global execute CHK and SET1

 K MA,DA,MB F ADMDT=0:0 S ADMDT=$O(^TMP($J,ADMDT)) Q:ADMDT=""  F LADM=0:0 S LADM=$O(^TMP($J,ADMDT,LADM)) Q:LADM=""  F DFN=0:0 S DFN=$O(^TMP($J,ADMDT,LADM,DFN)) Q:DFN=""  D CHK,SET1

DATA U IO W:(IOST?1"C-".E) @IOF

 W !,"Notices of discharge created on "_FDT(0)_" for discharge date range " S Y=$P(BDATE1,".",1) X ^DD("DD") W Y," TO " S Y=$P(EDATE1,".",1) X ^DD("DD") W Y,!!!

 W "Name",?35,"SSN",?50,"Admission date",! F LINE=1:1:IOM W "-"

 ;* Set up XRO array containing regional office station numbers

 ;*  contained in the AMIE Site Parameter File

 F I=0:0 S I=$O(^DVB(396.1,1,1,I)) Q:I=""!(+I=0)  S J=$P(^(I,0),U,1),J=$S($D(^DIC(4,+J,99)):$P(^(99),U),1:"") I J]"" S XRO(J)=""

 ;* Loop through Discharges ("AMV3") within entered date range DO SET

 ;*  when a discharge is found

 W !! S COUNT=0,MA=BDATE F J=0:0 S MA=$O(^DGPM("AMV3",MA)) Q:$P(MA,".")>EDATE!(MA="")  F DA=0:0 S DA=$O(^DGPM("AMV3",MA,DA)) Q:DA=""  F MB=0:0 S MB=$O(^DGPM("AMV3",MA,DA,MB)) Q:MB=""  I MA'>EDATE D SET

 ;* Loop through admission date TMP global

 D LOOK W @IOF,!!!,"Notice to MAS operator on ",FDT(0),!!! I '$D(NEW) W "There were no NOTICES OF DISCHARGE to create.",!!!

 I $D(NEW) W "There ",$S(COUNT=1:"was ",1:"were ")_COUNT_$S(COUNT=1:" notice",1:" notices")_" of discharge created.",!!!

KILL I $D(DVBAMAN)&($D(ZTQUEUED)) D KILL^%ZTLOAD

 K NEW,COUNT,XRO G KILL^DVBAUTIL

CREATE ;create notice

 ;* If a Notice of Discharge is requested on 7131, created it

 I $D(^DVB(396,XDA,2)) Q:$P(^(2),U,10)="L"

 Q:$P(^DVB(396,XDA,0),U,5)'="YES"  Q:$P(^(0),U,9)'="P"

 S XADMDT=$P(^DVB(396,XDA,0),U,4) Q:ADMDT'=XADMDT

CREAT1 Q:'$D(^DPT(DFN,0))  D ADM^DVBAVDPT

 I $G(CFLOC)="" Q   ;No station # for a claim folder location.

 I '$D(XRO(CFLOC))&(CFLOC'=376) Q  ;not a user RO

 I CFLOC=376,TDIS["DEATH" S CFLOC=$O(XRO(0)) Q:CFLOC=""

 Q:$D(^DVB(396.2,"D",ADMDT,DFN))  ;quit if one for admit date exists

 S (DIC,DIE)="^DVB(396.2,",DR="3.5///"_CFLOC_";1///"_ADMDT_";2///"_LADM_";3///R" S DLAYGO=396.2,DIC(0)="QLM",X=""""_SSN_"""" D ^DIC Q:+Y<0  S DA=+Y D ^DIE S NEW=1,COUNT=COUNT+1 K DLAYGO

 W PNAM,?35,SSN S Y=ADMDT X ^DD("DD") W ?50,Y,?70,TDIS,!

DOC ;XADMDT=admission date on 7131

 ;XDA=7131 file pointer--not all patients will have it

 ;DA=patient file pointer

 ;MB,LADM=admission pointers

 ;NOTE: DEATH,TO CNH discharges will NOT record discharge dates

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBADSCK   4531     printed  Feb 18, 2025@23:07:29                                                                                                                                                                                                    Page 2

DVBADSCK  ;ALB/GTS-557/THM-DISCHARGE CHECKER ;21 JUL 89

 +1       ;;2.7;AMIE;**15,14,24,32**;Apr 10, 1995

 +2       ;

 +3        SET DVBAMAN=""

 +4        DO NOPARM^DVBAUTL2

           if $DATA(DVBAQUIT)

               GOTO KILL

 +5        SET HD="MANUAL 7132 PROCESSING"

           DO HOME^%ZIS

           KILL ^TMP($JOB)

DATE       SET %DT(0)=-DT

           SET %DT="AE"

           SET %DT("A")="Enter BEGINNING date: "

 +1        WRITE @IOF,!?(IOM-$LENGTH(HD)\2),HD,!!!

 +2        DO ^%DT

           if Y<0

               GOTO KILL

           SET (BDATE,BDATE1)=Y

           SET BDATE=BDATE-.1

 +3        SET %DT("A")="     and ENDING date: "

           SET %DT="AE"

           DO ^%DT

           if Y<0

               GOTO DATE

           SET (EDATE1,EDATE)=Y

           SET EDATE=EDATE+.5

 +4        IF EDATE<BDATE

               WRITE *7,!!,"Invalid date sequence."

               HANG 3

               GOTO DATE

 +5        KILL %DT

           SET Y=DT

           XECUTE ^DD("DD")

           SET FDT(0)=Y

 +6        WRITE !!

           SET %ZIS="AEQ"

           SET %ZIS("A")="Enter output device: "

           DO ^%ZIS

           KILL %ZIS

           if POP

               GOTO KILL

 +7        IF $DATA(IO("Q"))

               SET ZTRTN="DATA^DVBADSCK"

               SET ZTIO=ION

               SET NOASK=1

               SET ZTDESC="AMIE Discharge Checker"

               FOR I="BDATE*","EDATE*","FDT(0)","HD","NOASK","DVBAMAN"

                   SET ZTSAVE(I)=""

 +8        IF $DATA(IO("Q"))

               DO ^%ZTLOAD

               if $DATA(ZTSK)

                   WRITE !!,"Request queued.",!

               GOTO KILL

 +9        GOTO DATA

 +10      ;

ZTM        DO NOPARM^DVBAUTL2

           if $DATA(DVBAQUIT)

               GOTO KILL

 +1        IF '$DATA(DT)

               SET X="T"

               DO ^%DT

               SET DT=Y

 +2        SET Y=DT

           XECUTE ^DD("DD")

           SET FDT(0)=Y

 +3        KILL ^TMP($JOB)

           SET X="T-1"

           DO ^%DT

           if Y<0

               QUIT

           SET (BDATE,BDATE1)=Y

           SET BDATE=Y-.1

           SET (EDATE1,EDATE)=Y

           SET EDATE=Y+.5

           GOTO DATA

 +4       ;

CHK       ;* Find the IFN of the 7131 which matches the admission date (If a 7131

 +1       ;*  exists).

 +2        FOR XDA=0:0

               SET XDA=$ORDER(^DVB(396,"B",DFN,XDA))

               if XDA=""

                   QUIT

               IF $PIECE($GET(^DVB(396,XDA,0)),U,4)=ADMDT&($PIECE($GET(^DVB(396,XDA,2)),U,10)="A")

                   QUIT

 +3        QUIT

 +4       ;

SET       ;* Set up TMP global of admissions for discharges within range

 +1        SET DFN=DA

           SET VAINDT=$SELECT($DATA(^DGPM(+MB,0)):$PIECE(^(0),U,1),1:"")

           SET VAINDT=VAINDT-.000002

           SET VA200=""

           DO INP^VADPT

           KILL VA200

           SET ADMDT=$PIECE(VAIN(7),U,1)

           SET ADMNUM=VAIN(1)

 +2       ;I ADMDT]"" S ADMDT=$P(ADMDT,".",1)

 +3        if ADMDT=""

               QUIT

           SET ^TMP($JOB,ADMDT,+ADMNUM,DA)=""

 +4        QUIT

 +5       ;

SET1      ;* Get the discharge type and execute CREATE and CREAT1 as needed

 +1        SET DCHPTR=$PIECE(^DGPM(LADM,0),U,17)

           SET TDIS=$SELECT($DATA(^DGPM(+DCHPTR,0)):$PIECE(^(0),U,18),1:"")

           IF TDIS=""

               SET TDIS="Unknown discharge type"

 +2        if '$DATA(^DG(405.2,+TDIS,0))

               SET TDIS="Unknown discharge type"

           IF $DATA(^(0))

               SET TDIS=$SELECT($PIECE(^DG(405.2,+TDIS,0),U,1)]"":$PIECE(^(0),U,1),1:"Unknown discharge type")

 +3        IF XDA]""

               IF $DATA(^DVB(396,XDA,0))

                   DO CREATE

                   QUIT

 +4        IF TDIS["DEATH"!(TDIS["TO CNH")

               DO CREAT1

 +5        QUIT

 +6       ;

LOOK      ;* Loop through Admission Date TMP global execute CHK and SET1

 +1        KILL MA,DA,MB

           FOR ADMDT=0:0

               SET ADMDT=$ORDER(^TMP($JOB,ADMDT))

               if ADMDT=""

                   QUIT

               FOR LADM=0:0

                   SET LADM=$ORDER(^TMP($JOB,ADMDT,LADM))

                   if LADM=""

                       QUIT

                   FOR DFN=0:0

                       SET DFN=$ORDER(^TMP($JOB,ADMDT,LADM,DFN))

                       if DFN=""

                           QUIT

                       DO CHK

                       DO SET1

 +2        QUIT

 +3       ;

DATA       USE IO

           if (IOST?1"C-".E)

               WRITE @IOF

 +1        WRITE !,"Notices of discharge created on "_FDT(0)_" for discharge date range "

           SET Y=$PIECE(BDATE1,".",1)

           XECUTE ^DD("DD")

           WRITE Y," TO "

           SET Y=$PIECE(EDATE1,".",1)

           XECUTE ^DD("DD")

           WRITE Y,!!!

 +2        WRITE "Name",?35,"SSN",?50,"Admission date",!

           FOR LINE=1:1:IOM

               WRITE "-"

 +3       ;

 +4       ;* Set up XRO array containing regional office station numbers

 +5       ;*  contained in the AMIE Site Parameter File

 +6       ;

 +7        FOR I=0:0

               SET I=$ORDER(^DVB(396.1,1,1,I))

               if I=""!(+I=0)

                   QUIT

               SET J=$PIECE(^(I,0),U,1)

               SET J=$SELECT($DATA(^DIC(4,+J,99)):$PIECE(^(99),U),1:"")

               IF J]""

                   SET XRO(J)=""

 +8       ;

 +9       ;* Loop through Discharges ("AMV3") within entered date range DO SET

 +10      ;*  when a discharge is found

 +11      ;

 +12       WRITE !!

           SET COUNT=0

           SET MA=BDATE

           FOR J=0:0

               SET MA=$ORDER(^DGPM("AMV3",MA))

               if $PIECE(MA,".")>EDATE!(MA="")

                   QUIT

               FOR DA=0:0

                   SET DA=$ORDER(^DGPM("AMV3",MA,DA))

                   if DA=""

                       QUIT

                   FOR MB=0:0

                       SET MB=$ORDER(^DGPM("AMV3",MA,DA,MB))

                       if MB=""

                           QUIT

                       IF MA'>EDATE

                           DO SET

 +13      ;

 +14      ;* Loop through admission date TMP global

 +15      ;

 +16       DO LOOK

           WRITE @IOF,!!!,"Notice to MAS operator on ",FDT(0),!!!

           IF '$DATA(NEW)

               WRITE "There were no NOTICES OF DISCHARGE to create.",!!!

 +17       IF $DATA(NEW)

               WRITE "There ",$SELECT(COUNT=1:"was ",1:"were ")_COUNT_$SELECT(COUNT=1:" notice",1:" notices")_" of discharge created.",!!!

 +18      ;

KILL       IF $DATA(DVBAMAN)&($DATA(ZTQUEUED))

               DO KILL^%ZTLOAD

 +1        KILL NEW,COUNT,XRO

           GOTO KILL^DVBAUTIL

 +2       ;

CREATE    ;create notice

 +1       ;* If a Notice of Discharge is requested on 7131, created it

 +2        IF $DATA(^DVB(396,XDA,2))

               if $PIECE(^(2),U,10)="L"

                   QUIT

 +3        if $PIECE(^DVB(396,XDA,0),U,5)'="YES"

               QUIT

           if $PIECE(^(0),U,9)'="P"

               QUIT

 +4        SET XADMDT=$PIECE(^DVB(396,XDA,0),U,4)

           if ADMDT'=XADMDT

               QUIT

CREAT1     if '$DATA(^DPT(DFN,0))

               QUIT

           DO ADM^DVBAVDPT

 +1       ;No station # for a claim folder location.

           IF $GET(CFLOC)=""

               QUIT

 +2       ;not a user RO

           IF '$DATA(XRO(CFLOC))&(CFLOC'=376)

               QUIT

 +3        IF CFLOC=376

               IF TDIS["DEATH"

                   SET CFLOC=$ORDER(XRO(0))

                   if CFLOC=""

                       QUIT

 +4       ;quit if one for admit date exists

           if $DATA(^DVB(396.2,"D",ADMDT,DFN))

               QUIT

 +5        SET (DIC,DIE)="^DVB(396.2,"

           SET DR="3.5///"_CFLOC_";1///"_ADMDT_";2///"_LADM_";3///R"

           SET DLAYGO=396.2

           SET DIC(0)="QLM"

           SET X=""""_SSN_""""

           DO ^DIC

           if +Y<0

               QUIT

           SET DA=+Y

           DO ^DIE

           SET NEW=1

           SET COUNT=COUNT+1

           KILL DLAYGO

 +6        WRITE PNAM,?35,SSN

           SET Y=ADMDT

           XECUTE ^DD("DD")

           WRITE ?50,Y,?70,TDIS,!

 +7        QUIT

 +8       ;

DOC       ;XADMDT=admission date on 7131

 +1       ;XDA=7131 file pointer--not all patients will have it

 +2       ;DA=patient file pointer

 +3       ;MB,LADM=admission pointers

 +4       ;NOTE: DEATH,TO CNH discharges will NOT record discharge dates

DVBADSCK.m