MAGUTL05 ;WOIFO/SG - MISCELLANEOUS UTILITIES ; 3/9/09 12:53pm
;;3.0;IMAGING;**93**;Dec 02, 2009;Build 163
;; Per VHA Directive 2004-038, this routine should not be modified.
;; +---------------------------------------------------------------+
;; | Property of the US Government. |
;; | No permission to copy or redistribute this software is given. |
;; | Use of unreleased versions of this software requires the user |
;; | to execute a written test agreement with the VistA Imaging |
;; | Development Office of the Department of Veterans Affairs, |
;; | telephone (301) 734-0100. |
;; | |
;; | The Food and Drug Administration classifies this software as |
;; | a medical device. As such, it may not be changed in any way. |
;; | Modifications to this software may result in an adulterated |
;; | medical device under 21CFR820, the use of which is considered |
;; | to be a violation of US Federal Statutes. |
;; +---------------------------------------------------------------+
;;
Q
;
;##### PREPARES THE VALUE FOR INDIRECTION
;
; This function returns the value of the parameter prepared for
; indirect assignment:
;
; * canonic numbers are returned as is;
;
; * strings are enclosed in double quotes and double quotes inside
; them are doubled. ;-)
;
DDQ(VAL) ;
N TMP S TMP=$NA(A(VAL))
Q $E(TMP,3,$L(TMP)-1)
;
;##### CHECKS IF THE TEXT BUFFER IS EMPTY
;
; MAG8NODE Name of a local or global node that contains the
; text (either in @MAG8NODE@(i) or in @MAG8NODE@(i,0)
; sub-nodes).
;
; Notes
; =====
;
; 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(MAG8NODE) ;
N MAG8EMPTY,MAG8I
S MAG8I="",MAG8EMPTY=1
F S MAG8I=$O(@MAG8NODE@(MAG8I)) Q:MAG8I="" D Q:'MAG8EMPTY
. I $G(@MAG8NODE@(MAG8I))'?." " S MAG8EMPTY=0 Q
. S:$G(@MAG8NODE@(MAG8I,0))'?." " MAG8EMPTY=0
. Q
Q MAG8EMPTY
;
;***** 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
;
; Notes
; =====
;
; This entry point can also be called as a procedure:
; D PAGE^MAGUTL05(...) if you do not need its return value.
;
PAGE(RESERVE,FORCE) ;
N RC
I ($Y'<($G(IOSL,24)-$G(RESERVE,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)
. Q
;---
Q:$QUIT +$G(RC) Q
;
;##### EMULATES $QUERY WITH 'DIRECTION' PARAMETER
;
; MAG8NODE Name of a node
;
; [MAG8DIR] Direction:
; $G(MAG8DIR)'<0 forward
; MAG8DIR<0 backward
;
Q(MAG8NODE,MAG8DIR) ;
Q:$G(MAG8DIR)'<0 $Q(@MAG8NODE)
N MAG8I,MAG8PI,MAG8TMP
S MAG8TMP=$QL(MAG8NODE) Q:MAG8TMP'>0 ""
S MAG8I=$QS(MAG8NODE,MAG8TMP),MAG8PI=$NA(@MAG8NODE,MAG8TMP-1)
;--- Find the previous node on the "lowest" level.
S MAG8I=$O(@MAG8PI@(MAG8I),-1)
;--- If there is none, then either return the parent node if it
;--- has data or perform the recursive query for the parent node.
Q:MAG8I="" $S($D(@MAG8PI)#10:MAG8PI,1:$$Q(MAG8PI,-1))
;--- Otherwise, get the last "lowest" child node.
F S MAG8PI=$NA(@MAG8PI@(MAG8I)) Q:$D(@MAG8PI)<10 D
. S MAG8I=$O(@MAG8PI@(""),-1)
. Q
Q MAG8PI
;
;##### "SENTENCE" CASE CONVERSION OF THE STRING
;
; STR Source string
;
; Return Values
; =============
; The source string converted to lover case except the
; first character, which is converted to upper case.
;
SNTC(STR) ;
Q $$UP^XLFSTR($E(STR))_$$LOW^XLFSTR($E(STR,2,$L(STR)))
;
;##### TRANSLATES CONTROL FLAGS
;
; FLAGS Source flags
;
; SRC All characters that are not included in the value
; of the SRC parameter are removed from the string
; passed in the FLAGS parameter.
;
; [DST] If the DST parameter is defined and not empty, then
; flags defined by the SRC parameter are translated to
; their counterparts in this parameter (see the
; $TRANSLATE function for additional details).
;
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 if necessary
Q $S($G(DST)'="":$TR(TMP,SRC,DST),1:TMP)
;
;##### 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)
;
;##### CHECKS IF THE PARAMETER VALUE IS A VALID PATIENT IEN (DFN)
;
; DFN Internal Entry Number of the patient record
;
; [.ERR] Reference to a local variable where the error
; descriptor (see the $$ERROR^MAGUERR) is returned to.
;
; After a successful call, this parameter is empty.
;
; These descriptors are NOT stored regarless of the
; mode set by the CLEAR^MAGUERR. If you need to store
; them (e.g. to return from an RPC), then you have to
; do this in your code (see the STORE^MAGUERR).
;
; Return Values
; =============
; 0 Parameter value is not a valid patient IEN (DFN);
; check the value of the ERR parameter for details.
; 1 Ok
;
;
VALDFN(DFN,ERR) ;
S ERR=""
I (DFN'>0)!(+DFN'=DFN) S ERR=$$ERROR^MAGUERR("-3S",,"DFN",DFN) Q 0
I '($D(^DPT(DFN,0))#2) S ERR=$$ERROR^MAGUERR("-5S",,DFN) Q 0
Q 1
;
;##### 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
;
;##### CREATES/UPDATES THE NODE HEADER 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGUTL05 7521 printed Jan 18, 2025@03:10:19 Page 2
MAGUTL05 ;WOIFO/SG - MISCELLANEOUS UTILITIES ; 3/9/09 12:53pm
+1 ;;3.0;IMAGING;**93**;Dec 02, 2009;Build 163
+2 ;; Per VHA Directive 2004-038, this routine should not be modified.
+3 ;; +---------------------------------------------------------------+
+4 ;; | Property of the US Government. |
+5 ;; | No permission to copy or redistribute this software is given. |
+6 ;; | Use of unreleased versions of this software requires the user |
+7 ;; | to execute a written test agreement with the VistA Imaging |
+8 ;; | Development Office of the Department of Veterans Affairs, |
+9 ;; | telephone (301) 734-0100. |
+10 ;; | |
+11 ;; | The Food and Drug Administration classifies this software as |
+12 ;; | a medical device. As such, it may not be changed in any way. |
+13 ;; | Modifications to this software may result in an adulterated |
+14 ;; | medical device under 21CFR820, the use of which is considered |
+15 ;; | to be a violation of US Federal Statutes. |
+16 ;; +---------------------------------------------------------------+
+17 ;;
+18 QUIT
+19 ;
+20 ;##### PREPARES THE VALUE FOR INDIRECTION
+21 ;
+22 ; This function returns the value of the parameter prepared for
+23 ; indirect assignment:
+24 ;
+25 ; * canonic numbers are returned as is;
+26 ;
+27 ; * strings are enclosed in double quotes and double quotes inside
+28 ; them are doubled. ;-)
+29 ;
DDQ(VAL) ;
+1 NEW TMP
SET TMP=$NAME(A(VAL))
+2 QUIT $EXTRACT(TMP,3,$LENGTH(TMP)-1)
+3 ;
+4 ;##### CHECKS IF THE TEXT BUFFER IS EMPTY
+5 ;
+6 ; MAG8NODE Name of a local or global node that contains the
+7 ; text (either in @MAG8NODE@(i) or in @MAG8NODE@(i,0)
+8 ; sub-nodes).
+9 ;
+10 ; Notes
+11 ; =====
+12 ;
+13 ; This function considers a buffer containing just space characters
+14 ; as empty.
+15 ;
+16 ; Return Values
+17 ; =============
+18 ; 0 The buffer is not empty
+19 ; 1 The buffer is empty
+20 ;
ISWPEMPT(MAG8NODE) ;
+1 NEW MAG8EMPTY,MAG8I
+2 SET MAG8I=""
SET MAG8EMPTY=1
+3 FOR
SET MAG8I=$ORDER(@MAG8NODE@(MAG8I))
if MAG8I=""
QUIT
Begin DoDot:1
+4 IF $GET(@MAG8NODE@(MAG8I))'?." "
SET MAG8EMPTY=0
QUIT
+5 if $GET(@MAG8NODE@(MAG8I,0))'?." "
SET MAG8EMPTY=0
+6 QUIT
End DoDot:1
if 'MAG8EMPTY
QUIT
+7 QUIT MAG8EMPTY
+8 ;
+9 ;***** CHECKS IF A NEW PAGE SHOULD BE STARTED
+10 ;
+11 ; [RESERVE] Number of reserved lines (1, by default).
+12 ; If the current page does not have so many lines
+13 ; available, a new page will be started.
+14 ;
+15 ; [FORCE] Force the prompt
+16 ;
+17 ; Return Values
+18 ; =============
+19 ; -2 Timeout
+20 ; -1 User canceled the output ('^' was entered)
+21 ; 0 Continue
+22 ; 1 New page and continue
+23 ;
+24 ; Notes
+25 ; =====
+26 ;
+27 ; This entry point can also be called as a procedure:
+28 ; D PAGE^MAGUTL05(...) if you do not need its return value.
+29 ;
PAGE(RESERVE,FORCE) ;
+1 NEW RC
+2 IF ($Y'<($GET(IOSL,24)-$GET(RESERVE,1)))!$GET(FORCE)
Begin DoDot:1
+3 IF $EXTRACT(IOST,1,2)'="C-"
WRITE @IOF
QUIT
+4 NEW DA,DIR,DIROUT,DTOUT,DUOUT,I,X,Y
+5 SET DIR(0)="E"
+6 DO ^DIR
+7 SET RC=$SELECT($DATA(DUOUT):-1,$DATA(DTOUT):-2,1:1)
+8 QUIT
End DoDot:1
SET $Y=0
+9 ;---
+10 if $QUIT
QUIT +$GET(RC)
QUIT
+11 ;
+12 ;##### EMULATES $QUERY WITH 'DIRECTION' PARAMETER
+13 ;
+14 ; MAG8NODE Name of a node
+15 ;
+16 ; [MAG8DIR] Direction:
+17 ; $G(MAG8DIR)'<0 forward
+18 ; MAG8DIR<0 backward
+19 ;
Q(MAG8NODE,MAG8DIR) ;
+1 if $GET(MAG8DIR)'<0
QUIT $QUERY(@MAG8NODE)
+2 NEW MAG8I,MAG8PI,MAG8TMP
+3 SET MAG8TMP=$QLENGTH(MAG8NODE)
if MAG8TMP'>0
QUIT ""
+4 SET MAG8I=$QSUBSCRIPT(MAG8NODE,MAG8TMP)
SET MAG8PI=$NAME(@MAG8NODE,MAG8TMP-1)
+5 ;--- Find the previous node on the "lowest" level.
+6 SET MAG8I=$ORDER(@MAG8PI@(MAG8I),-1)
+7 ;--- If there is none, then either return the parent node if it
+8 ;--- has data or perform the recursive query for the parent node.
+9 if MAG8I=""
QUIT $SELECT($DATA(@MAG8PI)#10:MAG8PI,1:$$Q(MAG8PI,-1))
+10 ;--- Otherwise, get the last "lowest" child node.
+11 FOR
SET MAG8PI=$NAME(@MAG8PI@(MAG8I))
if $DATA(@MAG8PI)<10
QUIT
Begin DoDot:1
+12 SET MAG8I=$ORDER(@MAG8PI@(""),-1)
+13 QUIT
End DoDot:1
+14 QUIT MAG8PI
+15 ;
+16 ;##### "SENTENCE" CASE CONVERSION OF THE STRING
+17 ;
+18 ; STR Source string
+19 ;
+20 ; Return Values
+21 ; =============
+22 ; The source string converted to lover case except the
+23 ; first character, which is converted to upper case.
+24 ;
SNTC(STR) ;
+1 QUIT $$UP^XLFSTR($EXTRACT(STR))_$$LOW^XLFSTR($EXTRACT(STR,2,$LENGTH(STR)))
+2 ;
+3 ;##### TRANSLATES CONTROL FLAGS
+4 ;
+5 ; FLAGS Source flags
+6 ;
+7 ; SRC All characters that are not included in the value
+8 ; of the SRC parameter are removed from the string
+9 ; passed in the FLAGS parameter.
+10 ;
+11 ; [DST] If the DST parameter is defined and not empty, then
+12 ; flags defined by the SRC parameter are translated to
+13 ; their counterparts in this parameter (see the
+14 ; $TRANSLATE function for additional details).
+15 ;
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 if necessary
+7 QUIT $SELECT($GET(DST)'="":$TRANSLATE(TMP,SRC,DST),1:TMP)
+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 ;##### CHECKS IF THE PARAMETER VALUE IS A VALID PATIENT IEN (DFN)
+4 ;
+5 ; DFN Internal Entry Number of the patient record
+6 ;
+7 ; [.ERR] Reference to a local variable where the error
+8 ; descriptor (see the $$ERROR^MAGUERR) is returned to.
+9 ;
+10 ; After a successful call, this parameter is empty.
+11 ;
+12 ; These descriptors are NOT stored regarless of the
+13 ; mode set by the CLEAR^MAGUERR. If you need to store
+14 ; them (e.g. to return from an RPC), then you have to
+15 ; do this in your code (see the STORE^MAGUERR).
+16 ;
+17 ; Return Values
+18 ; =============
+19 ; 0 Parameter value is not a valid patient IEN (DFN);
+20 ; check the value of the ERR parameter for details.
+21 ; 1 Ok
+22 ;
+23 ;
VALDFN(DFN,ERR) ;
+1 SET ERR=""
+2 IF (DFN'>0)!(+DFN'=DFN)
SET ERR=$$ERROR^MAGUERR("-3S",,"DFN",DFN)
QUIT 0
+3 IF '($DATA(^DPT(DFN,0))#2)
SET ERR=$$ERROR^MAGUERR("-5S",,DFN)
QUIT 0
+4 QUIT 1
+5 ;
+6 ;##### VALIDATES THE IENS
+7 ;
+8 ; IENS IENS of a record or a subfile; placeholders are not
+9 ; allowed (see FileMan DBS API manual for details).
+10 ;
+11 ; [FLAGS] Flags that control the execution (can be combined):
+12 ;
+13 ; S Subfile IENS are allowed
+14 ;
+15 ; Return Values
+16 ; =============
+17 ; 0 Invalid IENS
+18 ; 1 Ok
+19 ;
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 ;##### CREATES/UPDATES THE NODE HEADER IN THE ^XTMP GLOBAL
+13 ;
+14 ; SUBSCR Subscript of the node in the ^XTMP global
+15 ; [DKEEP] Number of days to keep the node (1 by default)
+16 ; [DESCR] Description of the node
+17 ;
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
