DVBAREN1.m

DVBAREN1 ;ALB/JLU;NEW 7131 REQ FOR NON-ADMIT VETS;9/20/94

 ;;2.7;AMIE;**14**;Apr 10, 1995

 ;this routine contains the logic to search for admissions, appointments, dispositions, and stop codes.

 ;

OLD ;this is the main entry point.

 S DVBANL=0

 I DVBCHK="A" D A1,COLADM

 I DVBCHK="N" D N1,COLAPT,COLLOG,COLSTP

 I DVBCHK="B" D B1,COLADM,COLAPT,COLLOG,COLSTP

 K DVBAWARN

 Q

A1 ;writes header statement for admission dates

 S VAR(1,0)="0,0,0,2:1,1^The following is a list of Admission dates for "_$P(DFN,U,2)

 D WR^DVBAUTL4("VAR")

 K VAR

 Q

 ;

N1 ;writes the header statement for activity dates

 S VAR(1,0)="0,0,0,2:1,1^The following is a list of activity dates for "_$P(DFN,U,2)

 D WR^DVBAUTL4("VAR")

 K VAR

 Q

 ;

B1 ;writes the header statement for both admission and activity dates

 S VAR(1,0)="0,0,0,2:1,1^The following is a list of Admission and Activity dates for "_$P(DFN,U,2)

 D WR^DVBAUTL4("VAR")

 K VAR

 Q

 ;

COLADM ;gathers the admission info. and stores in to the ^TMP global

 I DVBBDT=0 DO

 .N X,X1,X2

 .S X1=0

 .F X=1:1 S X1=$O(^DGPM("ATID1",+DFN,X1)) Q:'X1  D ADMSET(X1)

 .Q

 I DVBBDT>0 DO

 .N DVBBDT1,DVBEDT1,X,X1,X2

 .S DVBBDT1=9999999.9999999-(DVBBDT-.0000001)

 .S DVBEDT1=9999999.9999999-DVBEDT

 .S X1=DVBEDT1

 .F X=1:1 S X1=$O(^DGPM("ATID1",+DFN,X1)) Q:'X1!(X1>DVBBDT1)  D ADMSET(X1)

 .Q

 Q

 ;

ADMSET(A) ;starts the process of setting up the ^TMP global

 ;A is the internal entry number of the admission in the patient movement

 ;file.

 N X2,X3

 S X2=$O(^DGPM("ATID1",+DFN,A,0))

 S X3=$P(^DGPM(X2,0),U,4)

 Q:X3']""

 D SET(A,9999999.9999999-A,"ADMISSION",$P(^DG(405.1,X3,0),U,1),X2)

 S DVBANL=DVBANL+1

 Q

 ;

COLAPT ;gathers the appointment information

 I DVBBDT=0 DO

 .N X,X1,X2

 .S X1=0

 .F X=1:1 S X1=$O(^DPT(+DFN,"S",X1)) Q:'X1  D APTSET(X1)

 .Q

 I DVBBDT>0 DO

 .N X,X1

 .S X1=DVBBDT-.0000001

 .F X=1:1 S X1=$O(^DPT(+DFN,"S",X1)) Q:'X1!(X1>DVBEDT)  D APTSET(X1)

 .Q

 Q

 ;

APTSET(A) ;begins to set up the ^TMP global for appointments

 N X2

 S X2=$P(^DPT(+DFN,"S",A,0),U,1)

 S X2=$S($D(^SC(X2,0)):$P(^(0),U,1),1:"Unknown")

 D SET(9999999.9999999-X1,X1,"Appointment",X2)

 S DVBANL=DVBANL+1

 Q

 ;

COLSTP ;gathers the stop code information

 N DVBQUERY,DVBDFR,DVBDTO,DVBA,DVBA1,SDOE,SDOE0,DVBZERR

 S DVBDFR=$S(DVBBDT>0:DVBBDT,1:1),DVBDTO=$S(DVBBDT>0:DVBEDT\1+.99,1:9999999)

 ;

 D OPEN^SDQ(.DVBQUERY,"DVBZERR") Q:'$G(DVBQUERY)

 D INDEX^SDQ(.DVBQUERY,"PATIENT/DATE","SET","DVBZERR")

 D SCANCB^SDQ(.DVBQUERY,"I $P(SDOE0,U,3) S ^TMP(""DVBENC"",$J,+SDOE0)=$G(^TMP(""DVBENC"",$J,+SDOE0))+1","SET","DVBZERR")

 D PAT^SDQ(.DVBQUERY,+DFN,"SET","DVBZERR")

 D DATE^SDQ(.DVBQUERY,DVBDFR,DVBDTO,"SET","DVBZERR")

 D ACTIVE^SDQ(.DVBQUERY,"TRUE","SET","DVBZERR")

 K ^TMP("DVBENC",$J)

 D SCAN^SDQ(.DVBQUERY,"FORWARD","DVBZERR")

 D CLOSE^SDQ(.DVBQUERY)

 ;

 S DVBA=0 F  S DVBA=$O(^TMP("DVBENC",$J,DVBA)) Q:'DVBA  S DVBA1=^(DVBA) D

 . D SET(9999999.9999999-DVBA,DVBA,"Stop Code(s)",DVBA1_" Stops")

 . S DVBANL=DVBANL+1

 K ^TMP("DVBENC",$J)

 Q

 ;

COLLOG ;gathers the disposition information

 I DVBBDT>0 DO

 .N DVBBDT1,DVBEDT1,DVBA,DVBA1,DVBA2,DVBVAR

 .S DVBBDT1=9999999.9999999-(DVBBDT-.0000001)

 .S DVBEDT1=9999999.9999999-DVBEDT

 .S DVBA1=DVBEDT1

 .F DVBA=1:1 S DVBA1=$O(^DPT(+DFN,"DIS",DVBA1)) Q:'DVBA1!(DVBA1>DVBBDT1)  D DISSET(DVBA1)

 .Q

 I DVBBDT=0 DO

 .N DVBA,DVBA1,DVBA2

 .S DVBA1=0

 .F DVBA=1:1 S DVBA1=$O(^DPT(+DFN,"DIS",DVBA1)) Q:'DVBA1  D DISSET(DVBA1)

 .Q

 Q

 ;

DISSET(DVBA2) ;begins to set up the ^TMP with dispositions

 I '$D(^DPT(+DFN,"DIS",0)),'$D(DVBAWARN) DO

 .S VAR(1,0)="1,0,0,2:1,0^There is a problem with the Disposition Login information.  Contact IRM"

 .D WR^DVBAUTL4("VAR")

 .K VAR

 .D CONTMES^DVBCUTL4

 .S DVBAWARN=""

 I $D(^DPT(+DFN,"DIS",0)) DO  ;**Bullet Proof

 .K ^UTILITY("DIQ1",$J)

 .S DIC="^DPT(",DA=+DFN,DR=1000,DA(2.101)=DVBA2

 .S DR(2.101)=1,DIQ(0)="E"

 .D EN^DIQ1

 .K DIQ,DIC,DR,DA

 .D SET(DVBA2,9999999.9999999-DVBA2,"Disposition Login",^UTILITY("DIQ1",$J,2.101,DVBA2,1,"E"))

 .S DVBANL=DVBANL+1

 Q

 ;

SET(IDT,CDT,TYP,FTYP,X2) ;

 N VAR1

 S $P(VAR1," ",22)=""

 S Y=CDT

 D DD^%DT

 S ^TMP("DVBA",$J,IDT,TYP)=Y_$E(VAR1,1,23-$L(Y))_TYP_": "_FTYP_"^"_$S($D(X2):X2,1:"")

 Q

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DVBAREN1   4236     printed  Apr 23, 2025@17:56:29                                                                                                                                                                                                    Page 2

DVBAREN1  ;ALB/JLU;NEW 7131 REQ FOR NON-ADMIT VETS;9/20/94

 +1       ;;2.7;AMIE;**14**;Apr 10, 1995

 +2       ;this routine contains the logic to search for admissions, appointments, dispositions, and stop codes.

 +3       ;

OLD       ;this is the main entry point.

 +1        SET DVBANL=0

 +2        IF DVBCHK="A"

               DO A1

               DO COLADM

 +3        IF DVBCHK="N"

               DO N1

               DO COLAPT

               DO COLLOG

               DO COLSTP

 +4        IF DVBCHK="B"

               DO B1

               DO COLADM

               DO COLAPT

               DO COLLOG

               DO COLSTP

 +5        KILL DVBAWARN

 +6        QUIT 

A1        ;writes header statement for admission dates

 +1        SET VAR(1,0)="0,0,0,2:1,1^The following is a list of Admission dates for "_$PIECE(DFN,U,2)

 +2        DO WR^DVBAUTL4("VAR")

 +3        KILL VAR

 +4        QUIT 

 +5       ;

N1        ;writes the header statement for activity dates

 +1        SET VAR(1,0)="0,0,0,2:1,1^The following is a list of activity dates for "_$PIECE(DFN,U,2)

 +2        DO WR^DVBAUTL4("VAR")

 +3        KILL VAR

 +4        QUIT 

 +5       ;

B1        ;writes the header statement for both admission and activity dates

 +1        SET VAR(1,0)="0,0,0,2:1,1^The following is a list of Admission and Activity dates for "_$PIECE(DFN,U,2)

 +2        DO WR^DVBAUTL4("VAR")

 +3        KILL VAR

 +4        QUIT 

 +5       ;

COLADM    ;gathers the admission info. and stores in to the ^TMP global

 +1        IF DVBBDT=0

               Begin DoDot:1

 +2                NEW X,X1,X2

 +3                SET X1=0

 +4                FOR X=1:1

                       SET X1=$ORDER(^DGPM("ATID1",+DFN,X1))

                       if 'X1

                           QUIT 

                       DO ADMSET(X1)

 +5                QUIT 

               End DoDot:1

 +6        IF DVBBDT>0

               Begin DoDot:1

 +7                NEW DVBBDT1,DVBEDT1,X,X1,X2

 +8                SET DVBBDT1=9999999.9999999-(DVBBDT-.0000001)

 +9                SET DVBEDT1=9999999.9999999-DVBEDT

 +10               SET X1=DVBEDT1

 +11               FOR X=1:1

                       SET X1=$ORDER(^DGPM("ATID1",+DFN,X1))

                       if 'X1!(X1>DVBBDT1)

                           QUIT 

                       DO ADMSET(X1)

 +12               QUIT 

               End DoDot:1

 +13       QUIT 

 +14      ;

ADMSET(A) ;starts the process of setting up the ^TMP global

 +1       ;A is the internal entry number of the admission in the patient movement

 +2       ;file.

 +3        NEW X2,X3

 +4        SET X2=$ORDER(^DGPM("ATID1",+DFN,A,0))

 +5        SET X3=$PIECE(^DGPM(X2,0),U,4)

 +6        if X3']""

               QUIT 

 +7        DO SET(A,9999999.9999999-A,"ADMISSION",$PIECE(^DG(405.1,X3,0),U,1),X2)

 +8        SET DVBANL=DVBANL+1

 +9        QUIT 

 +10      ;

COLAPT    ;gathers the appointment information

 +1        IF DVBBDT=0

               Begin DoDot:1

 +2                NEW X,X1,X2

 +3                SET X1=0

 +4                FOR X=1:1

                       SET X1=$ORDER(^DPT(+DFN,"S",X1))

                       if 'X1

                           QUIT 

                       DO APTSET(X1)

 +5                QUIT 

               End DoDot:1

 +6        IF DVBBDT>0

               Begin DoDot:1

 +7                NEW X,X1

 +8                SET X1=DVBBDT-.0000001

 +9                FOR X=1:1

                       SET X1=$ORDER(^DPT(+DFN,"S",X1))

                       if 'X1!(X1>DVBEDT)

                           QUIT 

                       DO APTSET(X1)

 +10               QUIT 

               End DoDot:1

 +11       QUIT 

 +12      ;

APTSET(A) ;begins to set up the ^TMP global for appointments

 +1        NEW X2

 +2        SET X2=$PIECE(^DPT(+DFN,"S",A,0),U,1)

 +3        SET X2=$SELECT($DATA(^SC(X2,0)):$PIECE(^(0),U,1),1:"Unknown")

 +4        DO SET(9999999.9999999-X1,X1,"Appointment",X2)

 +5        SET DVBANL=DVBANL+1

 +6        QUIT 

 +7       ;

COLSTP    ;gathers the stop code information

 +1        NEW DVBQUERY,DVBDFR,DVBDTO,DVBA,DVBA1,SDOE,SDOE0,DVBZERR

 +2        SET DVBDFR=$SELECT(DVBBDT>0:DVBBDT,1:1)

           SET DVBDTO=$SELECT(DVBBDT>0:DVBEDT\1+.99,1:9999999)

 +3       ;

 +4        DO OPEN^SDQ(.DVBQUERY,"DVBZERR")

           if '$GET(DVBQUERY)

               QUIT 

 +5        DO INDEX^SDQ(.DVBQUERY,"PATIENT/DATE","SET","DVBZERR")

 +6        DO SCANCB^SDQ(.DVBQUERY,"I $P(SDOE0,U,3) S ^TMP(""DVBENC"",$J,+SDOE0)=$G(^TMP(""DVBENC"",$J,+SDOE0))+1","SET","DVBZERR")

 +7        DO PAT^SDQ(.DVBQUERY,+DFN,"SET","DVBZERR")

 +8        DO DATE^SDQ(.DVBQUERY,DVBDFR,DVBDTO,"SET","DVBZERR")

 +9        DO ACTIVE^SDQ(.DVBQUERY,"TRUE","SET","DVBZERR")

 +10       KILL ^TMP("DVBENC",$JOB)

 +11       DO SCAN^SDQ(.DVBQUERY,"FORWARD","DVBZERR")

 +12       DO CLOSE^SDQ(.DVBQUERY)

 +13      ;

 +14       SET DVBA=0

           FOR 

               SET DVBA=$ORDER(^TMP("DVBENC",$JOB,DVBA))

               if 'DVBA

                   QUIT 

               SET DVBA1=^(DVBA)

               Begin DoDot:1

 +15               DO SET(9999999.9999999-DVBA,DVBA,"Stop Code(s)",DVBA1_" Stops")

 +16               SET DVBANL=DVBANL+1

               End DoDot:1

 +17       KILL ^TMP("DVBENC",$JOB)

 +18       QUIT 

 +19      ;

COLLOG    ;gathers the disposition information

 +1        IF DVBBDT>0

               Begin DoDot:1

 +2                NEW DVBBDT1,DVBEDT1,DVBA,DVBA1,DVBA2,DVBVAR

 +3                SET DVBBDT1=9999999.9999999-(DVBBDT-.0000001)

 +4                SET DVBEDT1=9999999.9999999-DVBEDT

 +5                SET DVBA1=DVBEDT1

 +6                FOR DVBA=1:1

                       SET DVBA1=$ORDER(^DPT(+DFN,"DIS",DVBA1))

                       if 'DVBA1!(DVBA1>DVBBDT1)

                           QUIT 

                       DO DISSET(DVBA1)

 +7                QUIT 

               End DoDot:1

 +8        IF DVBBDT=0

               Begin DoDot:1

 +9                NEW DVBA,DVBA1,DVBA2

 +10               SET DVBA1=0

 +11               FOR DVBA=1:1

                       SET DVBA1=$ORDER(^DPT(+DFN,"DIS",DVBA1))

                       if 'DVBA1

                           QUIT 

                       DO DISSET(DVBA1)

 +12               QUIT 

               End DoDot:1

 +13       QUIT 

 +14      ;

DISSET(DVBA2) ;begins to set up the ^TMP with dispositions

 +1        IF '$DATA(^DPT(+DFN,"DIS",0))

               IF '$DATA(DVBAWARN)

                   Begin DoDot:1

 +2                    SET VAR(1,0)="1,0,0,2:1,0^There is a problem with the Disposition Login information.  Contact IRM"

 +3                    DO WR^DVBAUTL4("VAR")

 +4                    KILL VAR

 +5                    DO CONTMES^DVBCUTL4

 +6                    SET DVBAWARN=""

                   End DoDot:1

 +7       ;**Bullet Proof

           IF $DATA(^DPT(+DFN,"DIS",0))

               Begin DoDot:1

 +8                KILL ^UTILITY("DIQ1",$JOB)

 +9                SET DIC="^DPT("

                   SET DA=+DFN

                   SET DR=1000

                   SET DA(2.101)=DVBA2

 +10               SET DR(2.101)=1

                   SET DIQ(0)="E"

 +11               DO EN^DIQ1

 +12               KILL DIQ,DIC,DR,DA

 +13               DO SET(DVBA2,9999999.9999999-DVBA2,"Disposition Login",^UTILITY("DIQ1",$JOB,2.101,DVBA2,1,"E"))

 +14               SET DVBANL=DVBANL+1

               End DoDot:1

 +15       QUIT 

 +16      ;

SET(IDT,CDT,TYP,FTYP,X2) ;

 +1        NEW VAR1

 +2        SET $PIECE(VAR1," ",22)=""

 +3        SET Y=CDT

 +4        DO DD^%DT

 +5        SET ^TMP("DVBA",$JOB,IDT,TYP)=Y_$EXTRACT(VAR1,1,23-$LENGTH(Y))_TYP_": "_FTYP_"^"_$SELECT($DATA(X2):X2,1:"")

 +6        QUIT 

 +7       ;