- 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 Jan 18, 2025@03:41:25 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 ;