- 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 Feb 18, 2025@23:35:36 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