Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DVBCUTL4

DVBCUTL4.m

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