DVBAREG1.m

DVBAREG1 ;ALB/JLU;557/THM-REQ FOR ADMITTED VETS ; 10/29/90  7:53 AM

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

EN ;this is the main entry point for the driver

 D TERM

 I '$D(DVBAQUIT) DO

 .F  D BODY Q:$D(DVBAQUIT)

 .Q

 D EXIT^DVBAUTIL

 Q

 ;

TERM ;this subroutine will set various necessary variables

 ;

 K DVBAQUIT

 D DUZ2^DVBAUTIL

 Q:$D(DVBAQUIT)

 D NOPARM^DVBAUTL2

 Q:$D(DVBAQUIT)

 D HOME^%ZIS

 Q:$D(DVBAQUIT)

 S OPER=$S($D(^VA(200,+DUZ,0)):$P(^(0),U,1),1:"Unknown")

 S HD="PATIENT LOOKUP"

 S LOC=$S($D(^DIC(4,+DUZ(2),0)):$P(^(0),U,1),1:"")

 S HNAME=$$SITE^DVBCUTL4()

 S DVBAENTR=0

 Q

 ;

BODY ;this subroutine is a subdriver for this functionality

 S DVBAENTR=0

 D UNLOCK^DVBAUTL6(DVBAENTR) ;unlocks the record

 D CLEAN^DVBAREG2 ;cleans up some variables

 D PAGE^DVBAREG2 ;checks for bottom of the screen or page

 D SET1^DVBAREG3 ;sets a few variables

 S DFN=$$PAT^DVBAREG3() ;function call to get the patient

 I DFN=0 S DVBAQUIT=1 Q

 D SET2^DVBAREG3 ;sets up patient information variables

 D CLEAR^DVBAUTL4

 D DTRNG^DVBAREG2(DFN) ;gets the date range

 I $D(DVBAQUIT)!($D(DVBASTOP)) Q

 I DVBBDT>0 S DVBCHK=$$CHK(DFN,DVBBDT,DVBEDT)

 I DVBBDT=0 S DVBCHK=$$CHK(DFN,2010101,DT)

 D CLEAR^DVBAUTL4

 I DVBCHK=0 D ERR^DVBAUTL6(DVBBDT) S DVBASTOP=1 Q

 I DVBCHK="B" D QUEST1(DFN) Q:$D(DVBAQUIT)

 D OLD^DVBAREN1

 D DISPLAY

 Q:$D(DVBAQUIT)

 ;

 ;*The following line of code was removed as part of the coding to allow

 ;* Admission and Activity 7131s with the same date

 ;I $D(DVBANS) S DVBDOC=$$DOC^DVBAREG3(DVBANS)

 I '$D(DVBANS) DO SRCH I $D(DVBASTOP)!($D(DVBAQUIT))!('$D(DVBAENTR)) Q

 I $D(DVBANS) D SELECT^DVBAREG2

 Q:$D(DVBASTOP)!($D(DVBAQUIT))

 D ^DVBARQP

 D UNLOCK^DVBAUTL6(DVBAENTR)

 Q

 ;

CHK(A,B,C) ;checks for the existance of admissions, appointments, dispositions 

 ;or stop codes

 ;A is the DFN of the Patient

 ;B is the beginning date

 ;C is the ending date

 ;If all is selected then B and C should be dates that encompise all

 ;possible dates

 ;the date ranges provided must iclude the +/-for end of days

 N ADM,APT,DISP,SPCOD,B1,C1,C2,DVBADM,DVBAPT,DVBDISP,DVBSPCOD,DVBENC,DVBZERR

 S (DVBADM,DVBAPT,DVBDISP,DVBSPCOD)=0

 S B1=9999999.9999999-B

 S C1=9999999.9999999-C

 S ADM=$O(^DGPM("APTT1",+A,B))

 I ADM,ADM'>C S DVBADM=1

 S APT=$O(^DPT(+A,"S",B))

 I APT,APT'>C S DVBAPT=1

 S DISP=$O(^DPT(+A,"DIS",C1))

 I DISP,DISP'>B1 S DVBDISP=1

 ; Scheduling conversion

 S SPCOD=$$EXOE^SDOE(+A,B,9999999,,"DVBZERR")

 I SPCOD D GETGEN^SDOE(SPCOD,"DVBENC","DVBZERR") S SPCOD=$G(DVBENC(0))\1

 ;

 I SPCOD,SPCOD'>C S DVBSPCOD=1

 I DVBADM&((DVBAPT)!(DVBDISP)!(DVBSPCOD)) Q "B"

 I DVBADM Q "A"

 I DVBAPT!(DVBDISP)!(DVBSPCOD) Q "N"

 Q 0

 ;

QUEST1(DFN) ;ask user which they wish to see admission or non

 S DIR("A")="Which would you prefer"

 S DIR("A",1)=$P(DFN,U,2)_" has both Admission and Non Admission information."

 S DIR(0)="SM^A:Admissions;N:Non Admissions;B:Both"

 D ^DIR

 K DIR

 I $D(DTOUT)!($D(DUOUT))!(X="") S DVBAQUIT=1 Q

 S DVBCHK=Y

 Q

 ;

DISPLAY ;displays the patient information to the user.  Also asks the user

 ;to select which info.

 N X1,X2,X3,X4,VAR1

 I DVBANL=1 D SINGLE^DVBAREG2 Q

 K DVBANS

 S X2=$O(^TMP("DVBA",$J,0))

 I 'X2 S DVBASTOP=1 Q

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

 S (X1,DVBCNT)=0

 F  DO  Q:$D(DVBASTOP)!($D(DVBANS))

 .S XTYPE=""

 .F  S XTYPE=$O(^TMP("DVBA",$J,X2,XTYPE)) Q:XTYPE=""  DO

 ..S X1=X1+1

 ..S DVBCNT=DVBCNT+1

 ..S VAR(DVBCNT,0)="0,0,0,1,0^"_X1_$E(VAR1,1,5-$L(X1))_$P(^TMP("DVBA",$J,X2,XTYPE),U,1)

 ..I '(X1#12)!($O(^TMP("DVBA",$J,X2,XTYPE))=""&'$O(^TMP("DVBA",$J,X2))) DO

 ...D WR^DVBAUTL4("VAR")

 ...K VAR

 ...S DVBCNT=0

 ...D CONT^DVBAREG2

 .S X2=$O(^TMP("DVBA",$J,X2))

 .I '$D(DVBANS),('X2) S DVBASTOP=1 Q

 .Q

 I $D(DVBANS) DO

 .S (X3,X4)=0,(DVBTYPE,DVBDOC)=""

 .F  Q:+X3=+DVBANS  S X4=$O(^TMP("DVBA",$J,X4)) Q:X4=""  DO

 ..F  Q:+X3=+DVBANS  S DVBTYPE=$O(^TMP("DVBA",$J,X4,DVBTYPE)) Q:DVBTYPE=""  S X3=X3+1

 .S DVBANS=X4

 .S DVBDOC=$S(DVBTYPE["ADMISSION":"A",1:"L")

 .Q

 K XTYPE

 Q

 ;

SRCH ;searches the 7131 file for an existing 7131 request.

 K DA,Y,DVBASTOP,DVBAENTR

 D DICW^DVBAUTIL

 S VAR(1,0)="0,0,0,2,0^Searching file for existing 7131 requests for "_PNAM

 D WR^DVBAUTL4("VAR")

 K VAR

 S DIC="^DVB(396,",DIC(0)="EM",X=SSN

 I DVBCHK'="B",DVBBDT=0 S DIC("S")=$S(DVBCHK="A":"I $P(^(2),U,10)=""A""",1:"I $P(^(2),U,10)=""L"""),DVBDOC=$S(DVBCHK="A":"A",1:"L")

 I DVBCHK'="B",DVBBDT>0 S DIC("S")=$S(DVBCHK="A":"I $P(^(2),U,10)=""A""",1:"I $P(^(2),U,10)=""L""")_",$P(^(0),U,4)>(DVBBDT-.0000001),$P(^(0),U,4)<(DVBEDT+.0000001)"

 D ^DIC

 K DIC

 S DVBAY=Y

 I DVBAY<0 DO  Q

 .S VAR(1,0)="0,0,0,2:2,0^No selection made!"

 .D WR^DVBAUTL4("VAR")

 .K VAR

 .D CONTMES^DVBCUTL4

 .S DVBASTOP=1

 .Q

 I DVBAY>0 DO

 .I '$$LOCK^DVBAUTL6(+DVBAY) S DVBASTOP=1 Q

 .S (ZI,DA,DVBAIFN)=+DVBAY

 .S DVBREQDT=$P(^DVB(396,DA,0),U,4)

 .D ALERT^DVBAREG2(+DVBAY)

 .D ASK^DVBAREG2

 .Q:$D(DVBAQUIT)!($D(DVBASTOP))

 .S ONFILE=0

 .S DVBAENTR=+DVBAY

 .S DVBDOC=$P(^DVB(396,DVBAENTR,2),U,10)

 .I DVBDOC["A" S ADMNUM=$$ADM(DVBREQDT,+DFN)

 .I STAT'="" D ALERT1^DVBAREG2

 .I $D(DVBAQUIT) K DVBAEDT

 .I ONFILE=1 S DVBASTOP=1 Q

 .Q

 K DVBAY

 Q

 ;

ADM(A,B) ;This entry point will return the IEN in DGPM for the patient

 ;and admission date given.  A will be the admission date and B will

 ;be the DFN of the patient.

 ;

 N X

 S A=9999999.9999999-A

 S X=$O(^DGPM("ATID1",+B,A,0))

 I X DO

 .I '$D(^DGPM(X,0)) S X=""

 .Q

 I X="" Q 0

 Q X

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DVBAREG1   5478     printed  Mar 13, 2025@20:46:39                                                                                                                                                                                                    Page 2

DVBAREG1  ;ALB/JLU;557/THM-REQ FOR ADMITTED VETS ; 10/29/90  7:53 AM

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

EN        ;this is the main entry point for the driver

 +1        DO TERM

 +2        IF '$DATA(DVBAQUIT)

               Begin DoDot:1

 +3                FOR 

                       DO BODY

                       if $DATA(DVBAQUIT)

                           QUIT 

 +4                QUIT 

               End DoDot:1

 +5        DO EXIT^DVBAUTIL

 +6        QUIT 

 +7       ;

TERM      ;this subroutine will set various necessary variables

 +1       ;

 +2        KILL DVBAQUIT

 +3        DO DUZ2^DVBAUTIL

 +4        if $DATA(DVBAQUIT)

               QUIT 

 +5        DO NOPARM^DVBAUTL2

 +6        if $DATA(DVBAQUIT)

               QUIT 

 +7        DO HOME^%ZIS

 +8        if $DATA(DVBAQUIT)

               QUIT 

 +9        SET OPER=$SELECT($DATA(^VA(200,+DUZ,0)):$PIECE(^(0),U,1),1:"Unknown")

 +10       SET HD="PATIENT LOOKUP"

 +11       SET LOC=$SELECT($DATA(^DIC(4,+DUZ(2),0)):$PIECE(^(0),U,1),1:"")

 +12       SET HNAME=$$SITE^DVBCUTL4()

 +13       SET DVBAENTR=0

 +14       QUIT 

 +15      ;

BODY      ;this subroutine is a subdriver for this functionality

 +1        SET DVBAENTR=0

 +2       ;unlocks the record

           DO UNLOCK^DVBAUTL6(DVBAENTR)

 +3       ;cleans up some variables

           DO CLEAN^DVBAREG2

 +4       ;checks for bottom of the screen or page

           DO PAGE^DVBAREG2

 +5       ;sets a few variables

           DO SET1^DVBAREG3

 +6       ;function call to get the patient

           SET DFN=$$PAT^DVBAREG3()

 +7        IF DFN=0

               SET DVBAQUIT=1

               QUIT 

 +8       ;sets up patient information variables

           DO SET2^DVBAREG3

 +9        DO CLEAR^DVBAUTL4

 +10      ;gets the date range

           DO DTRNG^DVBAREG2(DFN)

 +11       IF $DATA(DVBAQUIT)!($DATA(DVBASTOP))

               QUIT 

 +12       IF DVBBDT>0

               SET DVBCHK=$$CHK(DFN,DVBBDT,DVBEDT)

 +13       IF DVBBDT=0

               SET DVBCHK=$$CHK(DFN,2010101,DT)

 +14       DO CLEAR^DVBAUTL4

 +15       IF DVBCHK=0

               DO ERR^DVBAUTL6(DVBBDT)

               SET DVBASTOP=1

               QUIT 

 +16       IF DVBCHK="B"

               DO QUEST1(DFN)

               if $DATA(DVBAQUIT)

                   QUIT 

 +17       DO OLD^DVBAREN1

 +18       DO DISPLAY

 +19       if $DATA(DVBAQUIT)

               QUIT 

 +20      ;

 +21      ;*The following line of code was removed as part of the coding to allow

 +22      ;* Admission and Activity 7131s with the same date

 +23      ;I $D(DVBANS) S DVBDOC=$$DOC^DVBAREG3(DVBANS)

 +24       IF '$DATA(DVBANS)

               DO SRCH

               IF $DATA(DVBASTOP)!($DATA(DVBAQUIT))!('$DATA(DVBAENTR))

                   QUIT 

 +25       IF $DATA(DVBANS)

               DO SELECT^DVBAREG2

 +26       if $DATA(DVBASTOP)!($DATA(DVBAQUIT))

               QUIT 

 +27       DO ^DVBARQP

 +28       DO UNLOCK^DVBAUTL6(DVBAENTR)

 +29       QUIT 

 +30      ;

CHK(A,B,C) ;checks for the existance of admissions, appointments, dispositions 

 +1       ;or stop codes

 +2       ;A is the DFN of the Patient

 +3       ;B is the beginning date

 +4       ;C is the ending date

 +5       ;If all is selected then B and C should be dates that encompise all

 +6       ;possible dates

 +7       ;the date ranges provided must iclude the +/-for end of days

 +8        NEW ADM,APT,DISP,SPCOD,B1,C1,C2,DVBADM,DVBAPT,DVBDISP,DVBSPCOD,DVBENC,DVBZERR

 +9        SET (DVBADM,DVBAPT,DVBDISP,DVBSPCOD)=0

 +10       SET B1=9999999.9999999-B

 +11       SET C1=9999999.9999999-C

 +12       SET ADM=$ORDER(^DGPM("APTT1",+A,B))

 +13       IF ADM

               IF ADM'>C

                   SET DVBADM=1

 +14       SET APT=$ORDER(^DPT(+A,"S",B))

 +15       IF APT

               IF APT'>C

                   SET DVBAPT=1

 +16       SET DISP=$ORDER(^DPT(+A,"DIS",C1))

 +17       IF DISP

               IF DISP'>B1

                   SET DVBDISP=1

 +18      ; Scheduling conversion

 +19       SET SPCOD=$$EXOE^SDOE(+A,B,9999999,,"DVBZERR")

 +20       IF SPCOD

               DO GETGEN^SDOE(SPCOD,"DVBENC","DVBZERR")

               SET SPCOD=$GET(DVBENC(0))\1

 +21      ;

 +22       IF SPCOD

               IF SPCOD'>C

                   SET DVBSPCOD=1

 +23       IF DVBADM&((DVBAPT)!(DVBDISP)!(DVBSPCOD))

               QUIT "B"

 +24       IF DVBADM

               QUIT "A"

 +25       IF DVBAPT!(DVBDISP)!(DVBSPCOD)

               QUIT "N"

 +26       QUIT 0

 +27      ;

QUEST1(DFN) ;ask user which they wish to see admission or non

 +1        SET DIR("A")="Which would you prefer"

 +2        SET DIR("A",1)=$PIECE(DFN,U,2)_" has both Admission and Non Admission information."

 +3        SET DIR(0)="SM^A:Admissions;N:Non Admissions;B:Both"

 +4        DO ^DIR

 +5        KILL DIR

 +6        IF $DATA(DTOUT)!($DATA(DUOUT))!(X="")

               SET DVBAQUIT=1

               QUIT 

 +7        SET DVBCHK=Y

 +8        QUIT 

 +9       ;

DISPLAY   ;displays the patient information to the user.  Also asks the user

 +1       ;to select which info.

 +2        NEW X1,X2,X3,X4,VAR1

 +3        IF DVBANL=1

               DO SINGLE^DVBAREG2

               QUIT 

 +4        KILL DVBANS

 +5        SET X2=$ORDER(^TMP("DVBA",$JOB,0))

 +6        IF 'X2

               SET DVBASTOP=1

               QUIT 

 +7        SET $PIECE(VAR1," ",5)=""

 +8        SET (X1,DVBCNT)=0

 +9        FOR 

               Begin DoDot:1

 +10               SET XTYPE=""

 +11               FOR 

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

                       if XTYPE=""

                           QUIT 

                       Begin DoDot:2

 +12                       SET X1=X1+1

 +13                       SET DVBCNT=DVBCNT+1

 +14                       SET VAR(DVBCNT,0)="0,0,0,1,0^"_X1_$EXTRACT(VAR1,1,5-$LENGTH(X1))_$PIECE(^TMP("DVBA",$JOB,X2,XTYPE),U,1)

 +15                       IF '(X1#12)!($ORDER(^TMP("DVBA",$JOB,X2,XTYPE))=""&'$ORDER(^TMP("DVBA",$JOB,X2)))

                               Begin DoDot:3

 +16                               DO WR^DVBAUTL4("VAR")

 +17                               KILL VAR

 +18                               SET DVBCNT=0

 +19                               DO CONT^DVBAREG2

                               End DoDot:3

                       End DoDot:2

 +20               SET X2=$ORDER(^TMP("DVBA",$JOB,X2))

 +21               IF '$DATA(DVBANS)

                       IF ('X2)

                           SET DVBASTOP=1

                           QUIT 

 +22               QUIT 

               End DoDot:1

               if $DATA(DVBASTOP)!($DATA(DVBANS))

                   QUIT 

 +23       IF $DATA(DVBANS)

               Begin DoDot:1

 +24               SET (X3,X4)=0

                   SET (DVBTYPE,DVBDOC)=""

 +25               FOR 

                       if +X3=+DVBANS

                           QUIT 

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

                       if X4=""

                           QUIT 

                       Begin DoDot:2

 +26                       FOR 

                               if +X3=+DVBANS

                                   QUIT 

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

                               if DVBTYPE=""

                                   QUIT 

                               SET X3=X3+1

                       End DoDot:2

 +27               SET DVBANS=X4

 +28               SET DVBDOC=$SELECT(DVBTYPE["ADMISSION":"A",1:"L")

 +29               QUIT 

               End DoDot:1

 +30       KILL XTYPE

 +31       QUIT 

 +32      ;

SRCH      ;searches the 7131 file for an existing 7131 request.

 +1        KILL DA,Y,DVBASTOP,DVBAENTR

 +2        DO DICW^DVBAUTIL

 +3        SET VAR(1,0)="0,0,0,2,0^Searching file for existing 7131 requests for "_PNAM

 +4        DO WR^DVBAUTL4("VAR")

 +5        KILL VAR

 +6        SET DIC="^DVB(396,"

           SET DIC(0)="EM"

           SET X=SSN

 +7        IF DVBCHK'="B"

               IF DVBBDT=0

                   SET DIC("S")=$SELECT(DVBCHK="A":"I $P(^(2),U,10)=""A""",1:"I $P(^(2),U,10)=""L""")

                   SET DVBDOC=$SELECT(DVBCHK="A":"A",1:"L")

 +8        IF DVBCHK'="B"

               IF DVBBDT>0

                   SET DIC("S")=$SELECT(DVBCHK="A":"I $P(^(2),U,10)=""A""",1:"I $P(^(2),U,10)=""L""")_",$P(^(0),U,4)>(DVBBDT-.0000001),$P(^(0),U,4)<(DVBEDT+.0000001)"

 +9        DO ^DIC

 +10       KILL DIC

 +11       SET DVBAY=Y

 +12       IF DVBAY<0

               Begin DoDot:1

 +13               SET VAR(1,0)="0,0,0,2:2,0^No selection made!"

 +14               DO WR^DVBAUTL4("VAR")

 +15               KILL VAR

 +16               DO CONTMES^DVBCUTL4

 +17               SET DVBASTOP=1

 +18               QUIT 

               End DoDot:1

               QUIT 

 +19       IF DVBAY>0

               Begin DoDot:1

 +20               IF '$$LOCK^DVBAUTL6(+DVBAY)

                       SET DVBASTOP=1

                       QUIT 

 +21               SET (ZI,DA,DVBAIFN)=+DVBAY

 +22               SET DVBREQDT=$PIECE(^DVB(396,DA,0),U,4)

 +23               DO ALERT^DVBAREG2(+DVBAY)

 +24               DO ASK^DVBAREG2

 +25               if $DATA(DVBAQUIT)!($DATA(DVBASTOP))

                       QUIT 

 +26               SET ONFILE=0

 +27               SET DVBAENTR=+DVBAY

 +28               SET DVBDOC=$PIECE(^DVB(396,DVBAENTR,2),U,10)

 +29               IF DVBDOC["A"

                       SET ADMNUM=$$ADM(DVBREQDT,+DFN)

 +30               IF STAT'=""

                       DO ALERT1^DVBAREG2

 +31               IF $DATA(DVBAQUIT)

                       KILL DVBAEDT

 +32               IF ONFILE=1

                       SET DVBASTOP=1

                       QUIT 

 +33               QUIT 

               End DoDot:1

 +34       KILL DVBAY

 +35       QUIT 

 +36      ;

ADM(A,B)  ;This entry point will return the IEN in DGPM for the patient

 +1       ;and admission date given.  A will be the admission date and B will

 +2       ;be the DFN of the patient.

 +3       ;

 +4        NEW X

 +5        SET A=9999999.9999999-A

 +6        SET X=$ORDER(^DGPM("ATID1",+B,A,0))

 +7        IF X

               Begin DoDot:1

 +8                IF '$DATA(^DGPM(X,0))

                       SET X=""

 +9                QUIT 

               End DoDot:1

 +10       IF X=""

               QUIT 0

 +11       QUIT X