DVBCUTL4 ;ALB-ISC/JLU/GTS-A utility routine ;2/22/93
;;2.7;AMIE;**57**;Apr 10, 1995
;
SITE() ;returns the site's name from the amie parameter file (396.1)
N DVBCX
S DVBCX=$O(^DVB(396.1,0))
I 'DVBCX Q "UNKNOWN"
Q $P(^(DVBCX,0),U,1) ;nake on SITE+2
;
EXAM() ;returns the next exam .01 number in the 396.4 Exam file
N DVBA,DVBA1
L +^DVB(396.1,1,5):3
I '$T Q 0 ;unable to lock parameter file node
S DVBA=$P(^DVB(396.1,1,5),U,1)
F DVBA1=0:0 S DVBA=DVBA+1 I '$D(^DVB(396.4,"B",DVBA)) Q
S $P(^DVB(396.1,1,5),U,1)=DVBA
L -^DVB(396.1,1,5)
Q DVBA ;contains new .01 value
;
EXSRH(A,B,C) ;searches for the exam for a specific request.
;A ==> The DIC("A") prompt for 396.6
;B ==> An optional screen on 396.6
;C ==> An optional screen on 396.4
;
N ERR
DO
.I $D(A),A]"" S DIC("A")=A
.I $D(B),B]"" S DIC("S")=B
.S DIC="^DVB(396.6,",DIC(0)="AEQM"
.D ^DIC K DIC
.I +Y<0!($D(DTOUT))!(X="")!(X=U) S ERR=-1 Q
.I $D(C),C]"" S DIC("S")=C
.S X=+Y,DIC="^DVB(396.4,",DIC(0)="EQ"
.S D="ARQ"_REQDA
.D IX^DIC K DIC,D
I $D(ERR),ERR<0 S Y=-1
Q Y
;
ROLLBCK ; ** Sort the ^TMP global to find added exams **
S DIK="^DVB(396.4,"
N DVBADA,DVBAEXNM,DVBARQDT
S (DVBADA,DVBAEXNM,DVBARQDT)=""
S DVBARQDT=$P(^DVB(396.3,REQDA,0),U,2)
F DVBACNT=0:0 S DVBAEXNM=$O(^TMP($J,"NEW",DVBAEXNM)) Q:DVBAEXNM="" D LOOP2
K DVBACNT,DVBADA,DVBAEXNM,DVBARQDT,DIK,DA
Q
;
LOOP2 ; ** Loop through 'PE' X-Ref:delete exams just added **
F DVBADA=0:0 S DVBADA=$O(^DVB(396.4,"APE",DFN,DVBAEXNM,DVBARQDT,DVBADA)) Q:DVBADA="" S DA=DVBADA D ^DIK
Q
;
CONTMES ; ** Continue Message to replace HANG statements **
W !!," Press RETURN to continue..." R DVBCCONT:DTIME K DVBCCONT
Q
;
EXMLOG1 ; ** Add exam (Called from DVBCADE2) **
S (DIC,DIE)="^DVB(396.4,",DIC(0)=""
K DD,DO
S DIC("DR")=".02////^S X=REQDA;.03////^S X=$P(^TMP($J,""NEW"",EXMNM),U,1);.04////O"
D FILE^DICN I $D(Y),(+Y>0) W:$X>40&($L(EXMNM)>30) !
W EXMNM_" -added, " W:$X>50 !
I $D(Y),+Y<0 W *7,"Exam addition error ! " S OUT=1 H 3 Q
S $P(^TMP($J,"NEW",EXMNM),U,3)=+Y
I $P(^DVB(396.3,REQDA,0),U,10)="E" DO
.I $D(^DVB(396.3,REQDA,5)) DO ;**Insuf 2507 entered after 2.7
..K DTOUT
..S DVBAINDA=+$P(^DVB(396.3,REQDA,5),U,1),DVBCADEX=""
..D INSXM^DVBCUTA1 K DVBCADEX
.I '$D(^DVB(396.3,REQDA,5)) DO ;**Insuf 2507 entered prior to 2.7
..N REASON
..S REASON=+$$INRSLK^DVBCUTA3
..I +REASON>0 DO
...K DIE,Y,DA,DR
...S DIE="^DVB(396.4,",DR=".11////^S X=REASON;80;.12"
...S DA=+$P(^TMP($J,"NEW",EXMNM),U,3)
...S DIE("NO^")="" D ^DIE K DIE,DA,DR,Y W !!
Q ;Quit to EXMLOG^DVBCADE2
;
STATCHK ; ** Check Statuses (Called from ^DVBCEDIT) **
Q:STAT="O" I STAT="RX" W *7,!!,"This exam has been cancelled by the RO.",!! H 2 S NCN=1 Q
I STAT="CT" W *7,!!,"This request has been completed and transferred out.",!! H 2 S NCN=1 Q
I STAT="C" W *7,!!,"This exam has been completed.",! S NCN=1 Q
I STAT="X" W *7,!!,"This exam has been cancelled by MAS.",!! H 2 S NCN=1 Q
I STAT="R" W *7,!!,"This exam has been released to the RO.",!! H 2 S NCN=1 Q
Q
;
COMP ; ** Check to see if transcription completed (Called from ^DVBCEDIT) **
K OUT Q:$P(^DVB(396.4,EXMDA,0),U,4)="C" W !!,"Is transcription completed for this exam" S %=2 D YN^DICN I $D(DTOUT) S OUT=1 Q
I $D(%Y),(%Y["?") W !!,"Enter Y if all information has been entered and transcription is finished",!,"or N if more information will be entered later",!! G COMP
Q:%'=1
K DIE,DA,DR
S DIE="^DVB(396.4,",DA=EXMDA,DR=".04///C;90///NOW"
D ^DIE
Q
;
PAUSE ;this is a pause, only looking for a return or up arrow
S DIR(0)="E"
D ^DIR
K DIR
Q
;
STM ;start response clock
I $D(XRTL) D T0^%ZOSV
Q
;
SPM ;stop monitor clock
I $D(XRT0) D T1^%ZOSV
K XRTN
Q
;
DELSER ;this subroutine will delete the server message
S XMZ=XQMSG
S XMSER="S."_XQSOP
D REMSBMSG^XMA1C
Q
;
PHYS(A) ; ** Question user for access to Physicians Guide **
S DIC(0)="AEMQ^^"
S DIC("A")="Select exam: "
;S DIR("?")="Enter Yes to access the Physician's Guide using Text Retreival."
D ^DIC
;I +Y=1 D PHYS^A1BBTR ;Access Physician's Guide
;I +Y=1 D PHYS^DRSTR ;** Access Physician's Guide
S:'$D(Y) Y=""
K DIR,X,Y(0)
Q Y
;
DATE(PAR1,PAR2) ;gets the beginning and ending dates from the users
;PAR1 is the beginning date
;PAR2 is the ending date
;
DATE1 S %DT("A")="Enter the beginning date: "
S %DT="AET"
D ^%DT
I X="^"!($D(DTOUT)) S (PAR1,PAR2)=0 Q
I X="" S (PAR1,PAR2)=-1 Q
S PAR1=Y
K %DT,Y,X,DTOUT
S %DT("A")="Enter the ending date: "
S %DT="AET"
D ^%DT
I X="^"!($D(DTOUT)) S (PAR1,PAR2)=0 Q
I X="" S (PAR1,PAR2)=-1 Q
S PAR2=Y
K %DT,X,Y,DTOUT
I PAR2<PAR1 DO G DATE1
.S VAR(1,0)="1,0,0,2:2,0^Beginning date must be before ending date!"
.D WR^DVBAUTL4("VAR")
.K VAR,PAR1,PAR2
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCUTL4 4847 printed Mar 13, 2025@20:53:56 Page 2
DVBCUTL4 ;ALB-ISC/JLU/GTS-A utility routine ;2/22/93
+1 ;;2.7;AMIE;**57**;Apr 10, 1995
+2 ;
SITE() ;returns the site's name from the amie parameter file (396.1)
+1 NEW DVBCX
+2 SET DVBCX=$ORDER(^DVB(396.1,0))
+3 IF 'DVBCX
QUIT "UNKNOWN"
+4 ;nake on SITE+2
QUIT $PIECE(^(DVBCX,0),U,1)
+5 ;
EXAM() ;returns the next exam .01 number in the 396.4 Exam file
+1 NEW DVBA,DVBA1
+2 LOCK +^DVB(396.1,1,5):3
+3 ;unable to lock parameter file node
IF '$TEST
QUIT 0
+4 SET DVBA=$PIECE(^DVB(396.1,1,5),U,1)
+5 FOR DVBA1=0:0
SET DVBA=DVBA+1
IF '$DATA(^DVB(396.4,"B",DVBA))
QUIT
+6 SET $PIECE(^DVB(396.1,1,5),U,1)=DVBA
+7 LOCK -^DVB(396.1,1,5)
+8 ;contains new .01 value
QUIT DVBA
+9 ;
EXSRH(A,B,C) ;searches for the exam for a specific request.
+1 ;A ==> The DIC("A") prompt for 396.6
+2 ;B ==> An optional screen on 396.6
+3 ;C ==> An optional screen on 396.4
+4 ;
+5 NEW ERR
+6 Begin DoDot:1
+7 IF $DATA(A)
IF A]""
SET DIC("A")=A
+8 IF $DATA(B)
IF B]""
SET DIC("S")=B
+9 SET DIC="^DVB(396.6,"
SET DIC(0)="AEQM"
+10 DO ^DIC
KILL DIC
+11 IF +Y<0!($DATA(DTOUT))!(X="")!(X=U)
SET ERR=-1
QUIT
+12 IF $DATA(C)
IF C]""
SET DIC("S")=C
+13 SET X=+Y
SET DIC="^DVB(396.4,"
SET DIC(0)="EQ"
+14 SET D="ARQ"_REQDA
+15 DO IX^DIC
KILL DIC,D
End DoDot:1
+16 IF $DATA(ERR)
IF ERR<0
SET Y=-1
+17 QUIT Y
+18 ;
ROLLBCK ; ** Sort the ^TMP global to find added exams **
+1 SET DIK="^DVB(396.4,"
+2 NEW DVBADA,DVBAEXNM,DVBARQDT
+3 SET (DVBADA,DVBAEXNM,DVBARQDT)=""
+4 SET DVBARQDT=$PIECE(^DVB(396.3,REQDA,0),U,2)
+5 FOR DVBACNT=0:0
SET DVBAEXNM=$ORDER(^TMP($JOB,"NEW",DVBAEXNM))
if DVBAEXNM=""
QUIT
DO LOOP2
+6 KILL DVBACNT,DVBADA,DVBAEXNM,DVBARQDT,DIK,DA
+7 QUIT
+8 ;
LOOP2 ; ** Loop through 'PE' X-Ref:delete exams just added **
+1 FOR DVBADA=0:0
SET DVBADA=$ORDER(^DVB(396.4,"APE",DFN,DVBAEXNM,DVBARQDT,DVBADA))
if DVBADA=""
QUIT
SET DA=DVBADA
DO ^DIK
+2 QUIT
+3 ;
CONTMES ; ** Continue Message to replace HANG statements **
+1 WRITE !!," Press RETURN to continue..."
READ DVBCCONT:DTIME
KILL DVBCCONT
+2 QUIT
+3 ;
EXMLOG1 ; ** Add exam (Called from DVBCADE2) **
+1 SET (DIC,DIE)="^DVB(396.4,"
SET DIC(0)=""
+2 KILL DD,DO
+3 SET DIC("DR")=".02////^S X=REQDA;.03////^S X=$P(^TMP($J,""NEW"",EXMNM),U,1);.04////O"
+4 DO FILE^DICN
IF $DATA(Y)
IF (+Y>0)
if $X>40&($LENGTH(EXMNM)>30)
WRITE !
+5 WRITE EXMNM_" -added, "
if $X>50
WRITE !
+6 IF $DATA(Y)
IF +Y<0
WRITE *7,"Exam addition error ! "
SET OUT=1
HANG 3
QUIT
+7 SET $PIECE(^TMP($JOB,"NEW",EXMNM),U,3)=+Y
+8 IF $PIECE(^DVB(396.3,REQDA,0),U,10)="E"
Begin DoDot:1
+9 ;**Insuf 2507 entered after 2.7
IF $DATA(^DVB(396.3,REQDA,5))
Begin DoDot:2
+10 KILL DTOUT
+11 SET DVBAINDA=+$PIECE(^DVB(396.3,REQDA,5),U,1)
SET DVBCADEX=""
+12 DO INSXM^DVBCUTA1
KILL DVBCADEX
End DoDot:2
+13 ;**Insuf 2507 entered prior to 2.7
IF '$DATA(^DVB(396.3,REQDA,5))
Begin DoDot:2
+14 NEW REASON
+15 SET REASON=+$$INRSLK^DVBCUTA3
+16 IF +REASON>0
Begin DoDot:3
+17 KILL DIE,Y,DA,DR
+18 SET DIE="^DVB(396.4,"
SET DR=".11////^S X=REASON;80;.12"
+19 SET DA=+$PIECE(^TMP($JOB,"NEW",EXMNM),U,3)
+20 SET DIE("NO^")=""
DO ^DIE
KILL DIE,DA,DR,Y
WRITE !!
End DoDot:3
End DoDot:2
End DoDot:1
+21 ;Quit to EXMLOG^DVBCADE2
QUIT
+22 ;
STATCHK ; ** Check Statuses (Called from ^DVBCEDIT) **
+1 if STAT="O"
QUIT
IF STAT="RX"
WRITE *7,!!,"This exam has been cancelled by the RO.",!!
HANG 2
SET NCN=1
QUIT
+2 IF STAT="CT"
WRITE *7,!!,"This request has been completed and transferred out.",!!
HANG 2
SET NCN=1
QUIT
+3 IF STAT="C"
WRITE *7,!!,"This exam has been completed.",!
SET NCN=1
QUIT
+4 IF STAT="X"
WRITE *7,!!,"This exam has been cancelled by MAS.",!!
HANG 2
SET NCN=1
QUIT
+5 IF STAT="R"
WRITE *7,!!,"This exam has been released to the RO.",!!
HANG 2
SET NCN=1
QUIT
+6 QUIT
+7 ;
COMP ; ** Check to see if transcription completed (Called from ^DVBCEDIT) **
+1 KILL OUT
if $PIECE(^DVB(396.4,EXMDA,0),U,4)="C"
QUIT
WRITE !!,"Is transcription completed for this exam"
SET %=2
DO YN^DICN
IF $DATA(DTOUT)
SET OUT=1
QUIT
+2 IF $DATA(%Y)
IF (%Y["?")
WRITE !!,"Enter Y if all information has been entered and transcription is finished",!,"or N if more information will be entered later",!!
GOTO COMP
+3 if %'=1
QUIT
+4 KILL DIE,DA,DR
+5 SET DIE="^DVB(396.4,"
SET DA=EXMDA
SET DR=".04///C;90///NOW"
+6 DO ^DIE
+7 QUIT
+8 ;
PAUSE ;this is a pause, only looking for a return or up arrow
+1 SET DIR(0)="E"
+2 DO ^DIR
+3 KILL DIR
+4 QUIT
+5 ;
STM ;start response clock
+1 IF $DATA(XRTL)
DO T0^%ZOSV
+2 QUIT
+3 ;
SPM ;stop monitor clock
+1 IF $DATA(XRT0)
DO T1^%ZOSV
+2 KILL XRTN
+3 QUIT
+4 ;
DELSER ;this subroutine will delete the server message
+1 SET XMZ=XQMSG
+2 SET XMSER="S."_XQSOP
+3 DO REMSBMSG^XMA1C
+4 QUIT
+5 ;
PHYS(A) ; ** Question user for access to Physicians Guide **
+1 SET DIC(0)="AEMQ^^"
+2 SET DIC("A")="Select exam: "
+3 ;S DIR("?")="Enter Yes to access the Physician's Guide using Text Retreival."
+4 DO ^DIC
+5 ;I +Y=1 D PHYS^A1BBTR ;Access Physician's Guide
+6 ;I +Y=1 D PHYS^DRSTR ;** Access Physician's Guide
+7 if '$DATA(Y)
SET Y=""
+8 KILL DIR,X,Y(0)
+9 QUIT Y
+10 ;
DATE(PAR1,PAR2) ;gets the beginning and ending dates from the users
+1 ;PAR1 is the beginning date
+2 ;PAR2 is the ending date
+3 ;
DATE1 SET %DT("A")="Enter the beginning date: "
+1 SET %DT="AET"
+2 DO ^%DT
+3 IF X="^"!($DATA(DTOUT))
SET (PAR1,PAR2)=0
QUIT
+4 IF X=""
SET (PAR1,PAR2)=-1
QUIT
+5 SET PAR1=Y
+6 KILL %DT,Y,X,DTOUT
+7 SET %DT("A")="Enter the ending date: "
+8 SET %DT="AET"
+9 DO ^%DT
+10 IF X="^"!($DATA(DTOUT))
SET (PAR1,PAR2)=0
QUIT
+11 IF X=""
SET (PAR1,PAR2)=-1
QUIT
+12 SET PAR2=Y
+13 KILL %DT,X,Y,DTOUT
+14 IF PAR2<PAR1
Begin DoDot:1
+15 SET VAR(1,0)="1,0,0,2:2,0^Beginning date must be before ending date!"
+16 DO WR^DVBAUTL4("VAR")
+17 KILL VAR,PAR1,PAR2
+18 QUIT
End DoDot:1
GOTO DATE1
+19 QUIT
