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

RAUTL22.m

Go to the documentation of this file.
  1. RAUTL22 ;HCIOFO/SG,GJC - GENERAL UTILITIES ; Feb 23, 2023@14:28:53
  1. ;;5.0;Radiology/Nuclear Medicine;**90,197**;Mar 16, 1998;Build 2
  1. ;
  1. ; Error codes -3, -8, and -10 can be returned by entry points of this
  1. ; routine. Therefore, if you export this routine, then the dialogs
  1. ; #700000.003, #700000.008, and 700000.01 should be exported as well.
  1. ;
  1. Q
  1. ;
  1. ;***** CHECKS IF ALL VARIABLES FROM THE LIST ARE NOT EMPTY
  1. ;
  1. ; ZZLST List of variable names separated by commas
  1. ;
  1. ; [ZZFLAGS] Flags that control the execution (can be combined):
  1. ;
  1. ; V By default, error messages (-8 and -10)
  1. ; reference parameters. If this flag is provided,
  1. ; then the messages that reference variable/nodes
  1. ; (-56 and -57) are used.
  1. ;
  1. ; Return values:
  1. ; <0 Error descriptor (see $$ERROR^RAERR)
  1. ; 0 Success
  1. ;
  1. CHKREQ(ZZLST,ZZFLAGS) ;
  1. N ZZCNT,ZZI,ZZL,ZZVAR
  1. S ZZL=$L(ZZLST,","),ZZCNT=0
  1. F ZZI=1:1:ZZL S ZZVAR=$P(ZZLST,",",ZZI) D:ZZVAR'=""
  1. . I $G(@ZZVAR)?." " D S ZZCNT=ZZCNT+1
  1. . . D ERROR^RAERR($S($G(ZZFLAGS)["V":-56,1:-8),,ZZVAR)
  1. Q $S(ZZCNT>0:$$ERROR^RAERR($S($G(ZZFLAGS)["V":-57,1:-10)),1:0)
  1. ;
  1. ;***** RETURNS FORMATTED TEXT OF THE DIALOG
  1. ;
  1. ; DLGNUM Dialog number (file #.84)
  1. ;
  1. ; [.PARAMS] Reference of a local array containing parameters for
  1. ; the BLD^DIALOG.
  1. ;
  1. ; [DIWR] The right margin for the text. Default: 75.
  1. ;
  1. ; [DIWF] Flags that control the execution (can be combined).
  1. ;
  1. ; A Append the text to the buffer. By default,
  1. ; the output buffer is cleared in the beginning
  1. ; of each call to DLGTXT.
  1. ;
  1. ; S Suppress blank lines added between chunks of
  1. ; text appended to the buffer. A blank line is
  1. ; never inserted if the buffer is empty.
  1. ;
  1. ; Any format control parameters supported by the
  1. ; ^DIWP except "I" and "W" can also be used.
  1. ;
  1. ; Return values:
  1. ; Closed root of the node in the ^UTILITY global that contains
  1. ; formatted text (output of the ^DIWP). Caller should KILL this
  1. ; node after retrieving the text.
  1. ;
  1. DLGTXT(DLGNUM,PARAMS,DIWR,DIWF) ;
  1. N DIWL,RA8BUF,RAI,X
  1. S DIWL=1 S:$G(DIWR)'>0 DIWR=75
  1. ;--- Check the flags
  1. S DIWF=$G(DIWF)
  1. I DIWF["A" D:DIWF'["S"
  1. . S:$G(^UTILITY($J,"W",DIWL))>0 RA8BUF(1)=" "
  1. E K ^UTILITY($J,"W")
  1. ;--- Load the text
  1. D BLD^DIALOG(DLGNUM,.PARAMS,,"RA8BUF","S")
  1. ;--- Remove the "A", "I", "S", and "W" flags
  1. S DIWF=$TR($G(DIWF),"ASW")
  1. F S RAI=$F(DIWF,"I") Q:'RAI D S $E(DIWF,RAI-1,X-1)=""
  1. . F X=RAI:1 Q:$E(DIWF,X)'?1N
  1. ;--- Reformat the text
  1. S RAI=""
  1. F S RAI=$O(RA8BUF(RAI)) Q:RAI="" S X=RA8BUF(RAI) D ^DIWP
  1. ;---
  1. Q $NA(^UTILITY($J,"W",DIWL))
  1. ;
  1. ;***** CHECKS IF THE DATE IS EXACT (INCLUDES MONTH AND DAY)
  1. ;
  1. ; DTE Date/time (FileMan)
  1. ;
  1. ; Return values:
  1. ; <0 Error descriptor (see $$ERROR^RAERR)
  1. ; 0 Date is not exact
  1. ; 1 Date is exact
  1. ;
  1. ISEXCTDT(DTE) ;
  1. N TMP S TMP=$G(DTE)\1
  1. Q:(TMP<1000000)!(TMP>9991231) $$IPVE^RAERR("DTE")
  1. Q ($E(TMP,4,5)>0)&($E(TMP,6,7)>0)
  1. ;
  1. ;***** CHECKS IF THE TEXT BUFFER IS EMPTY
  1. ;
  1. ; RA8NODE Name of a local or global node that contains the
  1. ; text (either in @RA8NODE@(i) or in @RA8NODE@(i,0)
  1. ; sub-nodes).
  1. ;
  1. ; NOTE: This function considers a buffer containing just space
  1. ; characters as empty.
  1. ;
  1. ; Return values:
  1. ; 0 The buffer is not empty
  1. ; 1 The buffer is empty
  1. ;
  1. ISWPEMPT(RA8NODE) ;
  1. N RA8EMPTY,RA8I
  1. S RA8I="",RA8EMPTY=1
  1. F S RA8I=$O(@RA8NODE@(RA8I)) Q:RA8I="" D Q:'RA8EMPTY
  1. . I $G(@RA8NODE@(RA8I))'?." " S RA8EMPTY=0 Q
  1. . S:$G(@RA8NODE@(RA8I,0))'?." " RA8EMPTY=0
  1. Q RA8EMPTY
  1. ;
  1. ;***** CHECKS IF A NEW PAGE SHOULD BE STARTED
  1. ;
  1. ; [RESERVE] Number of reserved lines (1, by default).
  1. ; If the current page does not have so many lines
  1. ; available, a new page will be started.
  1. ;
  1. ; [FORCE] Force the prompt
  1. ;
  1. ; Return values:
  1. ;
  1. ; -2 Timeout
  1. ; -1 User canceled the output ('^' was entered)
  1. ; 0 Continue
  1. ; 1 New page and continue
  1. ;
  1. ; NOTE: This entry point can also be called as a procedure:
  1. ; D PAGE^RAUTL22(...) if you do not need its return value.
  1. ;
  1. PAGE(RESERVE,FORCE) ;
  1. Q:$G(XPDNM)'="" 0 ; KIDS pre/post-install
  1. ;---
  1. N RC
  1. I ($Y'<($G(IOSL,24)-$G(RESERVE,1)-1))!$G(FORCE) D S $Y=0
  1. . I $E(IOST,1,2)'="C-" W @IOF Q
  1. . N DA,DIR,DIROUT,DTOUT,DUOUT,I,X,Y
  1. . S DIR(0)="E"
  1. . D ^DIR
  1. . S RC=$S($D(DUOUT):-1,$D(DTOUT):-2,1:1)
  1. ;---
  1. I $G(RC)<0 D:$G(RAPARAMS("PAGECTRL"))["E"
  1. . S $ECODE=$S(RC=-2:",UTIMEOUT,",1:",UCANCEL,")
  1. ;---
  1. Q:$QUIT +$G(RC) Q
  1. ;
  1. ;***** TRANSLATES FLAGS
  1. ;
  1. ; FLAGS Source flags
  1. ;
  1. ; SRC Source and destination patterns for translation
  1. ; DST (see the $TRANSLATE function for details).
  1. ;
  1. ; This function works similarly to the $TRANSLATE but it removes
  1. ; those flags (characters) that are not included in the SRC.
  1. ;
  1. TRFLAGS(FLAGS,SRC,DST) ;
  1. N TMP
  1. ;--- Get flags that are not included in the SRC
  1. S TMP=$TR(FLAGS,SRC)
  1. ;--- Remove these flags
  1. S TMP=$TR(FLAGS,TMP)
  1. ;--- Translate valid flags
  1. Q $TR(TMP,SRC,DST)
  1. ;
  1. ;***** TRUNCATES THE STRING AND APPENDS "..."
  1. ;
  1. ; STR Source string
  1. ; MAXLEN Maximum allowed length
  1. ;
  1. TRUNC(STR,MAXLEN) ;
  1. Q $S($L(STR)>MAXLEN:$E(STR,1,MAXLEN-3)_"...",1:STR)
  1. ;
  1. ;***** VALIDATES THE IENS
  1. ;
  1. ; IENS IENS of a record or a subfile; placeholders are not
  1. ; allowed (see FileMan DBS API manual for details).
  1. ;
  1. ; [FLAGS] Flags that control the execution (can be combined):
  1. ;
  1. ; S Subfile IENS are allowed
  1. ;
  1. ; Return Values:
  1. ; 0 Invalid IENS
  1. ; 1 Ok
  1. ;
  1. VALIENS(IENS,FLAGS) ;
  1. N I,L,IEN,RC
  1. S L=$L(IENS,",")
  1. ;--- The last piece should be empty (trailing comma is required)
  1. Q:$P(IENS,",",L)'="" 0
  1. ;--- The first piece should be either a canonic number or empty
  1. S I=$S(($P(IENS,",")="")&($G(FLAGS)["S"):2,1:1)
  1. ;--- All pieces in between should be canonic numbers
  1. S RC=1
  1. F I=I:1:L-1 S IEN=$P(IENS,",",I) I (IEN'>0)!(+IEN'=IEN) S RC=0 Q
  1. Q RC
  1. ;
  1. ;***** WRITES THE MESSAGE (ACCORDING TO THE ENVIRONMENT)
  1. ;
  1. ; MSG Message
  1. ;
  1. ; [SKIP] If this parameter is defined and non-zero, then an
  1. ; empty line is written above the message.
  1. ;
  1. W(MSG,SKIP) ;
  1. I $D(XPDENV)!($G(XPDNM)="") W:$G(SKIP) ! W !,MSG Q
  1. I $G(SKIP) D BMES^XPDUTL(MSG) Q
  1. D MES^XPDUTL(MSG)
  1. Q
  1. ;
  1. ;***** CREATES A HEADER OF THE NODE IN THE ^XTMP GLOBAL
  1. ;
  1. ; SUBSCR Subscript of the node in the ^XTMP global
  1. ; [DKEEP] Number of days to keep the node (1 by default)
  1. ; [DESCR] Description of the node
  1. ;
  1. XTMPHDR(SUBSCR,DKEEP,DESCR) ;
  1. N DATE S DATE=$$DT^XLFDT S:$G(DKEEP)'>0 DKEEP=1
  1. S ^XTMP(SUBSCR,0)=$$FMADD^XLFDT(DATE,DKEEP)_U_DATE_U_$G(DESCR)
  1. Q
  1. ;
  1. ;***** EMULATES AND EXTENDS THE ZWRITE COMMAND :-)
  1. ;
  1. ; ZZ8NODE Closed root of the sub-tree to display
  1. ; (either local array or global variable)
  1. ;
  1. ; [ZZ8TTL] Title of the output
  1. ;
  1. ; [ZZ8FLG] Flags that control the execution (can be combined):
  1. ;
  1. ; N Do not print node names
  1. ;
  1. ; P Paginate the output
  1. ;
  1. ; S Skip a line before the output
  1. ;
  1. ZW(ZZ8NODE,ZZ8TTL,ZZ8FLG) ;
  1. Q:ZZ8NODE="" Q:'$D(@ZZ8NODE)
  1. N ZZ8FLT,ZZ8L,ZZ8PI,ZZ8RC
  1. S ZZ8FLG=$G(ZZ8FLG),ZZ8RC=0
  1. ;
  1. ;--- Skip a line before the output
  1. I ZZ8FLG["S" D Q:ZZ8RC<0
  1. . I ZZ8FLG["P" S ZZ8RC=$$PAGE(1) Q:ZZ8RC<0
  1. . W !
  1. ;
  1. ;--- Write the title (if provided)
  1. I $G(ZZ8TTL)'="" D Q:ZZ8RC<0
  1. . I ZZ8FLG["P" S ZZ8RC=$$PAGE(2) Q:ZZ8RC<0
  1. . W !,ZZ8TTL,!
  1. ;
  1. ;--- Write the root node's value (if defined)
  1. I $D(@ZZ8NODE)#10 D Q:ZZ8RC<0
  1. . I ZZ8FLG["P" S ZZ8RC=$$PAGE() Q:ZZ8RC<0
  1. . W ! W:ZZ8FLG'["N" ZZ8NODE_"=" W """"_@ZZ8NODE_""""
  1. ;
  1. ;--- Write values of sub-nodes
  1. S ZZ8L=$L(ZZ8NODE) S:$E(ZZ8NODE,ZZ8L)=")" ZZ8L=ZZ8L-1
  1. S ZZ8FLT=$E(ZZ8NODE,1,ZZ8L),ZZ8PI=ZZ8NODE
  1. F S ZZ8PI=$Q(@ZZ8PI) Q:$E(ZZ8PI,1,ZZ8L)'=ZZ8FLT D Q:ZZ8RC<0
  1. . I ZZ8FLG["P" S ZZ8RC=$$PAGE() Q:ZZ8RC<0
  1. . W ! W:ZZ8FLG'["N" ZZ8PI_"=" W """"_@ZZ8PI_""""
  1. Q
  1. ;
  1. ;***** CHECKS IF THE EXAM DATE/TIME IS VALID (P197)
  1. ;
  1. ; RADTE Date/time (FileMan)
  1. ;
  1. ; RAX return values:
  1. ; 0 Date is not valid
  1. ; 1 Date is valid
  1. ;
  1. ISEXDTVAL(RADTE) ;seconds stripped ski p197
  1. N RAX D DT^DILF("XRPE",$$FMTE^XLFDT(RADTE,1),.RAX)
  1. Q $S(RAX=-1:0,1:1)
  1. ;