DVBAREG2 ;ALB/JLU;second half of the 7131 input;3/2/99
;;2.7;AMIE;**3,5,14,17,20,25**;Apr 10, 1995
;
CONT ;asks selection from list
S DIR(0)="NAO^1:"_X1_":0"
S DIR("A")="Select 1-"_X1_" or '^' to Exit or Return to continue "
D ^DIR
K DIR
I $D(DTOUT)!$D(DUOUT) S DVBASTOP=1 Q
I Y]"" S DVBANS=Y
E K DVBANS
Q
;
SINGLE ;when select single entry point
S XTYPE=""
S X1=$O(^TMP("DVBA",$J,0))
I X1="" S DVBASTOP=1 Q
S XTYPE=$O(^TMP("DVBA",$J,X1,XTYPE))
I XTYPE="" S DVBASTOP=1 Q
S DIR("A",1)=""
S DIR("A",2)=$P(^TMP("DVBA",$J,X1,XTYPE),U)
S DIR("A")="Is this the correct information? "
S DIR("B")="NO"
S DIR(0)="YA"
D ^DIR
K DIR
I $D(DUOUT)!($D(DTOUT)) S DVBASTOP=1 Q
I Y S DVBANS=X1,DVBTYPE=XTYPE,DVBDOC=$S(DVBTYPE["ADMISSION":"A",1:"L")
E K DVBANS
Q
;
DTRNG(DFN) ;gets date range from user
S DIR("A",1)="Display Admission or Activity information"
S DIR("A")="for "_$P(DFN,U,2)_" by"
S DIR("?")="Date Range will allow the user to select the specific dates."
S DIR("?",1)="All Dates will show the user all possible information."
S DIR(0)="SM^D:Date Range;A:All Dates"
D ^DIR
K DIR
I $D(DTOUT)!($D(DUOUT)) S DVBAQUIT=1 Q
I X="" S DVBASTOP=1 Q
S DVBBDT=0,DVBEDT=0
S VAR(1,0)="0,0,0,1,0^"
D WR^DVBAUTL4("VAR")
K VAR
I Y="D" DO
.D DATE^DVBCUTL4(.DVBBDT,.DVBEDT)
.S Y="D"
.I DVBBDT>0,'+$P(DVBBDT,".",2) S DVBBDT=DVBBDT-.0000001
.I DVBEDT>0,'+$P(DVBEDT,".",2) S DVBEDT=DVBEDT+.9999999
.I DVBBDT=0,DVBEDT=0 S DVBAQUIT=1
.I DVBBDT=-1,DVBEDT=-1 S DVBASTOP=1
.Q
Q
;
CLEAN ;cleans up variables
K DA,ADM,ADMDT,ADMNUM,DFN,DIC,A,DR,PNAM,SSN,TRN,Z,DINUM,DTAR,C,J,K,L,C,D,DIE,ONFILE,%,OLDDA,%Y,DIK,ZI,X,Y,AROWOUT,DVBAEDT,DVBAENTR,DVBASTOP,DVBREQDT,DVBANS,DVBTYPE
K ^TMP("DVBA",$J),^UTILITY("DIQ1",$J)
Q
;
PAGE ;pages/dispays end of page/screen
S VAR(1,0)="0,0,0,0,1^"
S VAR(2,0)="0,0,"_(IOM-$L(HD)\2)_":0,0,0^"_HD
S VAR(3,0)="0,0,"_(IOM-$L(HNAME)\2)_":0,1:2,0^"_HNAME
D WR^DVBAUTL4("VAR")
K VAR
Q
;
SELECT ;checks doc type, request status and calls deletion, if necessary
N ZI
K DVBAENTR
S DVBREQDT=9999999.9999999-DVBANS
I DVBTYPE["ADMISSION" DO
.S ADMNUM=$P(^TMP("DVBA",$J,DVBANS,DVBTYPE),U,2)
D COMPSEL
Q
;
COMPSEL ;** Compare selected 7131 to existing
N DVBATMPT
I DVBTYPE["ADMISSION" S DVBATMPT="A"
I DVBTYPE'["ADMISSION" S DVBATMPT="L"
F ZI=0:0 S ZI=$O(^DVB(396,"B",+DFN,ZI)) Q:ZI="" I $D(^DVB(396,"G",+$E(DVBREQDT,1,14),ZI))&(DVBATMPT=$P(^DVB(396,ZI,2),"^",10)) S DVBAENTR=ZI Q
I $D(DVBAENTR) DO
.D ALERT(ZI)
.D ASK
.Q:$D(DVBAQUIT)!($D(DVBASTOP))
.I '$$LOCK^DVBAUTL6(DVBAENTR) S DVBASTOP=1 Q
.S STAT=$P(^DVB(396,DVBAENTR,1),U,12)
.S ONFILE=0
.I STAT'="" D ALERT1
.Q:$D(DVBAQUIT)!($D(DVBASTOP))
.I ONFILE=1 S DVBASTOP=1 Q
.Q
I '$D(DVBAENTR) DO
.D DICW^DVBAUTIL
.D ASK1
.I $D(DVBASTOP)!($D(DVBAQUIT)) Q
.D STUFF
.Q
I '$D(DVBAENTR) S DVBASTOP=1
Q
;
ALERT(Y) ;displays when a potential hit in the 7131 file.
S VAR(1,0)="1,0,0,2,0^There is a 7131 already on file for "_$$FMTE^XLFDT(DVBREQDT,"5DZ")
S STAT=$P(^DVB(396,+Y,1),U,12)
S VAR(2,0)="0,0,0,1:1,0^Status is "_$S(STAT'="":"FINALIZED",1:"OPEN")
D WR^DVBAUTL4("VAR")
K VAR
Q
ALERT1 ;
I STAT'="" DO
.S VAR(1,0)="0,0,0,1,0^"
.D WR^DVBAUTL4("VAR")
.K VAR
.S DIR("A")="Do you want to delete the existing 7131 for this date: "
.S DIR(0)="YAO"
.S DIR("B")="NO"
.S DIR("?")="Answer YES or No. You may not have two 7131s for the same admission date."
.D ^DIR
.K DIR
.I $D(DTOUT)!($D(DUOUT))!(Y="") S DVBAQUIT=1 Q
.I 'Y S DVBASTOP=1 Q
.I Y DO
..S DA=+DVBAENTR
..D REOPEN^DVBAUTL2
..K DA
..Q
.Q
Q
;
ASK1 ;ask user if wish to add new 7131
S DVBAASIH=$P(DVBREQDT,".",2) ;*ASIH admit? (P4,v2.7)
D:$L(DVBAASIH)>6 ASIHALRT^DVBAUTL8 ;**Warn ASIH admit
S VAR(1,0)="1,0,0,1,0^"
D WR^DVBAUTL4("VAR")
K VAR
S DIR("A",1)="Do you want to add a NEW 7131"
S DIR("A")="for "_$P(PNAM,",",2,99)_" "_$P(PNAM,",",1,1)_" :"
S DIR(0)="YAO"
S DIR("B")="NO"
S DIR("?")="'YES' to enter a new 7131. 'NO' to search for an existing one."
D ^DIR
K DIR,DVBAASIH
I $D(DUOUT)!($D(DTOUT)) S DVBAQUIT=1 Q
S:Y=1 DVBREQDT=+$E(DVBREQDT,1,14)
I Y=0 S DVBASTOP=1 Q
Q
;
ASK ;ask the user if wish to edit existing 7131
S VAR(1,0)="1,0,0,1,0^"
D WR^DVBAUTL4("VAR")
K VAR
S DIR("A")="Are you sure you want to edit this 7131 request: "
S DIR("B")="NO"
S DIR("?")="'YES' to edit the 7131 request."
S DIR(0)="YAO"
D ^DIR
K DIR
I $D(DUOUT)!($D(DTOUT)) S DVBAQUIT=1 Q
I Y=0 S DVBASTOP=1 Q
I Y=1 S DVBAEDT=1
Q
;
STUFF ;enters 7131 into 7131 form file
K DA,DIC("S"),DD,DO
S DLAYGO=396,DIC(0)="QLM",DIC="^DVB(396,",X=+DFN
D FILE^DICN
I 'Y DO S DVBASTOP=1 Q
.S VAR(1,0)="1,0,0,2,0^Unable to add this new record!"
.D WR^DVBAUTL4("VAR")
.K VAR
.Q
I '$$LOCK^DVBAUTL6(Y) S DVBASTOP=1 Q
S (DA,DVBAENTR)=+Y
S DR="1////"_CNUM_";2////"_SSN_";3////"_DVBREQDT_";23////"_DT_";24////"_DT_";27////"_LOC_";28////"_OPER_";30////"_$S($D(ADMNUM):"A",1:"L")
S DIE=DIC
D ^DIE
K DA,DLAYGO,DIC,DIE
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAREG2 5106 printed Apr 09, 2024@20:58:42 Page 2
DVBAREG2 ;ALB/JLU;second half of the 7131 input;3/2/99
+1 ;;2.7;AMIE;**3,5,14,17,20,25**;Apr 10, 1995
+2 ;
CONT ;asks selection from list
+1 SET DIR(0)="NAO^1:"_X1_":0"
+2 SET DIR("A")="Select 1-"_X1_" or '^' to Exit or Return to continue "
+3 DO ^DIR
+4 KILL DIR
+5 IF $DATA(DTOUT)!$DATA(DUOUT)
SET DVBASTOP=1
QUIT
+6 IF Y]""
SET DVBANS=Y
+7 IF '$TEST
KILL DVBANS
+8 QUIT
+9 ;
SINGLE ;when select single entry point
+1 SET XTYPE=""
+2 SET X1=$ORDER(^TMP("DVBA",$JOB,0))
+3 IF X1=""
SET DVBASTOP=1
QUIT
+4 SET XTYPE=$ORDER(^TMP("DVBA",$JOB,X1,XTYPE))
+5 IF XTYPE=""
SET DVBASTOP=1
QUIT
+6 SET DIR("A",1)=""
+7 SET DIR("A",2)=$PIECE(^TMP("DVBA",$JOB,X1,XTYPE),U)
+8 SET DIR("A")="Is this the correct information? "
+9 SET DIR("B")="NO"
+10 SET DIR(0)="YA"
+11 DO ^DIR
+12 KILL DIR
+13 IF $DATA(DUOUT)!($DATA(DTOUT))
SET DVBASTOP=1
QUIT
+14 IF Y
SET DVBANS=X1
SET DVBTYPE=XTYPE
SET DVBDOC=$SELECT(DVBTYPE["ADMISSION":"A",1:"L")
+15 IF '$TEST
KILL DVBANS
+16 QUIT
+17 ;
DTRNG(DFN) ;gets date range from user
+1 SET DIR("A",1)="Display Admission or Activity information"
+2 SET DIR("A")="for "_$PIECE(DFN,U,2)_" by"
+3 SET DIR("?")="Date Range will allow the user to select the specific dates."
+4 SET DIR("?",1)="All Dates will show the user all possible information."
+5 SET DIR(0)="SM^D:Date Range;A:All Dates"
+6 DO ^DIR
+7 KILL DIR
+8 IF $DATA(DTOUT)!($DATA(DUOUT))
SET DVBAQUIT=1
QUIT
+9 IF X=""
SET DVBASTOP=1
QUIT
+10 SET DVBBDT=0
SET DVBEDT=0
+11 SET VAR(1,0)="0,0,0,1,0^"
+12 DO WR^DVBAUTL4("VAR")
+13 KILL VAR
+14 IF Y="D"
Begin DoDot:1
+15 DO DATE^DVBCUTL4(.DVBBDT,.DVBEDT)
+16 SET Y="D"
+17 IF DVBBDT>0
IF '+$PIECE(DVBBDT,".",2)
SET DVBBDT=DVBBDT-.0000001
+18 IF DVBEDT>0
IF '+$PIECE(DVBEDT,".",2)
SET DVBEDT=DVBEDT+.9999999
+19 IF DVBBDT=0
IF DVBEDT=0
SET DVBAQUIT=1
+20 IF DVBBDT=-1
IF DVBEDT=-1
SET DVBASTOP=1
+21 QUIT
End DoDot:1
+22 QUIT
+23 ;
CLEAN ;cleans up variables
+1 KILL DA,ADM,ADMDT,ADMNUM,DFN,DIC,A,DR,PNAM,SSN,TRN,Z,DINUM,DTAR,C,J,K,L,C,D,DIE,ONFILE,%,OLDDA,%Y,DIK,ZI,X,Y,AROWOUT,DVBAEDT,DVBAENTR,DVBASTOP,DVBREQDT,DVBANS,DVBTYPE
+2 KILL ^TMP("DVBA",$JOB),^UTILITY("DIQ1",$JOB)
+3 QUIT
+4 ;
PAGE ;pages/dispays end of page/screen
+1 SET VAR(1,0)="0,0,0,0,1^"
+2 SET VAR(2,0)="0,0,"_(IOM-$LENGTH(HD)\2)_":0,0,0^"_HD
+3 SET VAR(3,0)="0,0,"_(IOM-$LENGTH(HNAME)\2)_":0,1:2,0^"_HNAME
+4 DO WR^DVBAUTL4("VAR")
+5 KILL VAR
+6 QUIT
+7 ;
SELECT ;checks doc type, request status and calls deletion, if necessary
+1 NEW ZI
+2 KILL DVBAENTR
+3 SET DVBREQDT=9999999.9999999-DVBANS
+4 IF DVBTYPE["ADMISSION"
Begin DoDot:1
+5 SET ADMNUM=$PIECE(^TMP("DVBA",$JOB,DVBANS,DVBTYPE),U,2)
End DoDot:1
+6 DO COMPSEL
+7 QUIT
+8 ;
COMPSEL ;** Compare selected 7131 to existing
+1 NEW DVBATMPT
+2 IF DVBTYPE["ADMISSION"
SET DVBATMPT="A"
+3 IF DVBTYPE'["ADMISSION"
SET DVBATMPT="L"
+4 FOR ZI=0:0
SET ZI=$ORDER(^DVB(396,"B",+DFN,ZI))
if ZI=""
QUIT
IF $DATA(^DVB(396,"G",+$EXTRACT(DVBREQDT,1,14),ZI))&(DVBATMPT=$PIECE(^DVB(396,ZI,2),"^",10))
SET DVBAENTR=ZI
QUIT
+5 IF $DATA(DVBAENTR)
Begin DoDot:1
+6 DO ALERT(ZI)
+7 DO ASK
+8 if $DATA(DVBAQUIT)!($DATA(DVBASTOP))
QUIT
+9 IF '$$LOCK^DVBAUTL6(DVBAENTR)
SET DVBASTOP=1
QUIT
+10 SET STAT=$PIECE(^DVB(396,DVBAENTR,1),U,12)
+11 SET ONFILE=0
+12 IF STAT'=""
DO ALERT1
+13 if $DATA(DVBAQUIT)!($DATA(DVBASTOP))
QUIT
+14 IF ONFILE=1
SET DVBASTOP=1
QUIT
+15 QUIT
End DoDot:1
+16 IF '$DATA(DVBAENTR)
Begin DoDot:1
+17 DO DICW^DVBAUTIL
+18 DO ASK1
+19 IF $DATA(DVBASTOP)!($DATA(DVBAQUIT))
QUIT
+20 DO STUFF
+21 QUIT
End DoDot:1
+22 IF '$DATA(DVBAENTR)
SET DVBASTOP=1
+23 QUIT
+24 ;
ALERT(Y) ;displays when a potential hit in the 7131 file.
+1 SET VAR(1,0)="1,0,0,2,0^There is a 7131 already on file for "_$$FMTE^XLFDT(DVBREQDT,"5DZ")
+2 SET STAT=$PIECE(^DVB(396,+Y,1),U,12)
+3 SET VAR(2,0)="0,0,0,1:1,0^Status is "_$SELECT(STAT'="":"FINALIZED",1:"OPEN")
+4 DO WR^DVBAUTL4("VAR")
+5 KILL VAR
+6 QUIT
ALERT1 ;
+1 IF STAT'=""
Begin DoDot:1
+2 SET VAR(1,0)="0,0,0,1,0^"
+3 DO WR^DVBAUTL4("VAR")
+4 KILL VAR
+5 SET DIR("A")="Do you want to delete the existing 7131 for this date: "
+6 SET DIR(0)="YAO"
+7 SET DIR("B")="NO"
+8 SET DIR("?")="Answer YES or No. You may not have two 7131s for the same admission date."
+9 DO ^DIR
+10 KILL DIR
+11 IF $DATA(DTOUT)!($DATA(DUOUT))!(Y="")
SET DVBAQUIT=1
QUIT
+12 IF 'Y
SET DVBASTOP=1
QUIT
+13 IF Y
Begin DoDot:2
+14 SET DA=+DVBAENTR
+15 DO REOPEN^DVBAUTL2
+16 KILL DA
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 QUIT
+20 ;
ASK1 ;ask user if wish to add new 7131
+1 ;*ASIH admit? (P4,v2.7)
SET DVBAASIH=$PIECE(DVBREQDT,".",2)
+2 ;**Warn ASIH admit
if $LENGTH(DVBAASIH)>6
DO ASIHALRT^DVBAUTL8
+3 SET VAR(1,0)="1,0,0,1,0^"
+4 DO WR^DVBAUTL4("VAR")
+5 KILL VAR
+6 SET DIR("A",1)="Do you want to add a NEW 7131"
+7 SET DIR("A")="for "_$PIECE(PNAM,",",2,99)_" "_$PIECE(PNAM,",",1,1)_" :"
+8 SET DIR(0)="YAO"
+9 SET DIR("B")="NO"
+10 SET DIR("?")="'YES' to enter a new 7131. 'NO' to search for an existing one."
+11 DO ^DIR
+12 KILL DIR,DVBAASIH
+13 IF $DATA(DUOUT)!($DATA(DTOUT))
SET DVBAQUIT=1
QUIT
+14 if Y=1
SET DVBREQDT=+$EXTRACT(DVBREQDT,1,14)
+15 IF Y=0
SET DVBASTOP=1
QUIT
+16 QUIT
+17 ;
ASK ;ask the user if wish to edit existing 7131
+1 SET VAR(1,0)="1,0,0,1,0^"
+2 DO WR^DVBAUTL4("VAR")
+3 KILL VAR
+4 SET DIR("A")="Are you sure you want to edit this 7131 request: "
+5 SET DIR("B")="NO"
+6 SET DIR("?")="'YES' to edit the 7131 request."
+7 SET DIR(0)="YAO"
+8 DO ^DIR
+9 KILL DIR
+10 IF $DATA(DUOUT)!($DATA(DTOUT))
SET DVBAQUIT=1
QUIT
+11 IF Y=0
SET DVBASTOP=1
QUIT
+12 IF Y=1
SET DVBAEDT=1
+13 QUIT
+14 ;
STUFF ;enters 7131 into 7131 form file
+1 KILL DA,DIC("S"),DD,DO
+2 SET DLAYGO=396
SET DIC(0)="QLM"
SET DIC="^DVB(396,"
SET X=+DFN
+3 DO FILE^DICN
+4 IF 'Y
Begin DoDot:1
+5 SET VAR(1,0)="1,0,0,2,0^Unable to add this new record!"
+6 DO WR^DVBAUTL4("VAR")
+7 KILL VAR
+8 QUIT
End DoDot:1
SET DVBASTOP=1
QUIT
+9 IF '$$LOCK^DVBAUTL6(Y)
SET DVBASTOP=1
QUIT
+10 SET (DA,DVBAENTR)=+Y
+11 SET DR="1////"_CNUM_";2////"_SSN_";3////"_DVBREQDT_";23////"_DT_";24////"_DT_";27////"_LOC_";28////"_OPER_";30////"_$SELECT($DATA(ADMNUM):"A",1:"L")
+12 SET DIE=DIC
+13 DO ^DIE
+14 KILL DA,DLAYGO,DIC,DIE
+15 QUIT
+16 ;
