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 ---[H[J[2J[HDVBAREG1 5478 printed Oct 16, 2024@17:42:51 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
