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