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 ---[H[J[2J[HDVBAREN1 4236 printed Sep 23, 2025@19:18:02 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 ;
