- MAGBRTE5 ;WOIFO/PMK - Background Routing - Load Balance ; 06/08/2007 10:28
- ;;3.0;IMAGING;**11,30,51,85,54**;03-July-2009;;Build 1424
- ;; 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
- ;
- BALANCE(IMAGE,RULE) N %,D,DEST,PARENT,PRI,X
- S PARENT=$P(^MAG(2005,IMAGE,0),"^",10) ; ~~~
- D:'$D(^MAGRT(2006.5906,RULE,1,PARENT))
- . N CP,M1,M2,MAX,B,E,L,RD,T
- . ;
- . L +^MAGRT(2006.5906,0):1E9 ; Background task must wait for lock
- . ;
- . ; Clean up old info
- . ; Allow for a study to cross one day boundary,
- . ; and remove everything that is older than a day.
- . ;
- . S RD=RDT-1 F S RD=$O(^MAGRT(2006.5906,"D",RD),-1) Q:'RD D
- . . N DE,RU,PA
- . . S DE="" F S DE=$O(^MAGRT(2006.5906,"D",RD,DE)) Q:DE="" D
- . . . S RU="" F S RU=$O(^MAGRT(2006.5906,"D",RD,DE,RU)) Q:RU="" D
- . . . . S PA="" F S PA=$O(^MAGRT(2006.5906,"D",RD,DE,RU,PA)) Q:PA="" D
- . . . . . K ^MAGRT(2006.5906,"D",RD,DE,RU,PA)
- . . . . . K ^MAGRT(2006.5906,RU,1,PA)
- . . . . . S X=^MAGRT(2006.5906,RU,1,0)
- . . . . . S $P(X,"^",4)=$P(X,"^",4)-1
- . . . . . S ^MAGRT(2006.5906,RU,1,0)=X
- . . . . . Q
- . . . . Q
- . . . Q
- . . Q
- . ;
- . D:'$D(^MAGRT(2006.5906,RULE))
- . . S X=$G(^MAGRT(2006.5906,0))
- . . S $P(X,"^",1,2)="ROUTE LOAD BALANCE^2006.5906"
- . . S:RULE>$P(X,"^",3) $P(X,"^",3)=RULE
- . . S $P(X,"^",4)=$P(X,"^",4)+1
- . . S:RULE>$P(X,"^",3) $P(X,"^",3)=RULE
- . . S ^MAGRT(2006.5906,0)=X
- . . S ^MAGRT(2006.5906,RULE,0)=RULE
- . . Q
- . ;
- . M CP=^MAGRT(2006.5906,"D",RDT)
- . S (B,DEST,L,M1,M2,MAX)=0
- . F S DEST=$O(RULE(RULE,"ACTION",DEST)) Q:'DEST D
- . . N I,T
- . . S B=B+1,B(B)=DEST
- . . S X=RULE(RULE,"ACTION",DEST)
- . . S M(B)=$P(X,"^",2),MAX=MAX+M(B)
- . . ; Don't exceed maximum number of studies per day days
- . . S T=0,I="" F S I=$O(CP(DEST,I)) Q:I="" S T=T+1
- . . I $P(X,"^",3),T'<$P(X,"^",3) S M2=M2+M(B),M(B)=-1,M1=M1+1
- . . Q
- . ; If one destination has reached its cap, redistribute...
- . D:M1
- . . N I,L,R
- . . S R=M2#M1,L=0
- . . F I=1:1:B S:M(I)>0 M(I)=M2\M1+M(I),L=I
- . . S M(L)=M(L)+R
- . . Q
- . ;
- . S X=$G(^MAGRT(2006.5906,RULE,2))
- . ; X = LAST ^ TOTAL ^ COUNT(DEST) ^ COUNT(DEST) ^ ...
- . F L=1:1:B S E(L)=+$P(X,"^",L+2)
- . S L=$P(X,"^",1) F S L=L+1 S:L>B L=1 Q:E(L)<M(L)
- . S T=$P(X,"^",2)+1,E(L)=E(L)+1,DEST=B(L)
- . I T'<MAX S T=0 F L=1:1:B S E(L)=0
- . S X=L_"^"_T F L=1:1:B S X=X_"^"_E(L)
- . S ^MAGRT(2006.5906,RULE,2)=X
- . ;
- . ; Note: on consolidated sites 'origins' and 'destinations'
- . ; matter even more than on non-consolidated ones.
- . ; In the case of load-balancing, however, the 'destinations'
- . ; part is taken care of by the balancing parameters, and the
- . ; origin is moot, because each study has one (and only one)
- . ; origin.
- . ;
- . D:'$D(^MAGRT(2006.5906,RULE,1,PARENT))
- . . S X=$G(^MAGRT(2006.5906,RULE,1,0))
- . . S $P(X,"^",1,2)="^2006.59061"
- . . S:PARENT>$P(X,"^",3) $P(X,"^",3)=PARENT
- . . S $P(X,"^",4)=$P(X,"^",4)+1
- . . S ^MAGRT(2006.5906,RULE,1,0)=X
- . . S ^MAGRT(2006.5906,RULE,1,PARENT,0)=PARENT_"^"_RDT_"^"_DEST
- . . Q
- . L -^MAGRT(2006.5906,0)
- . Q
- S DEST=$P(^MAGRT(2006.5906,RULE,1,PARENT,0),"^",3)
- S X=$G(RULE(RULE,"ACTION",DEST))
- I X="" S METMSG(0,"No location for rule "_RULE_", alternative "_DEST)="" Q
- S X=$P(X,"^",1) Q:X="<LOCAL>"
- S DEST=0
- S D=0 F S D=$O(RULE(RULE,"ACTION",D)) Q:'D D Q:DEST
- . Q:$P($G(RULE(RULE,"ACTION",D)),"^",1)'=X
- . S DEST=D
- . Q
- I 'DEST S METMSG(0,"Cannot find location """_X_""".")="" Q
- S ^MAGRT(2006.5906,"D",RDT,DEST,RULE,PARENT)=""
- ;
- ; Current version assumes that BALANCE means DOS-Copy, not DICOM...
- D VALDEST^MAGDRPC1(.DEST,X)
- D LOG("Load-Balance Destination is "_X)
- S PRI=$$PRI^MAGBRTE4($G(RULE(RULE,"PRIORITY")),IMAGE)
- S VRS=$$VRS(VRS,$$SEND(IMAGE,DEST,PRI,1,LOCATION))
- Q
- ;
- VARNAME(F) ;
- S F=$TR(F," !""#$%&'()*+,-./:;<=>?@[\]^_`{|}~","_________________________________")
- F Q:F'["__" S F=$P(F,"__",1)_"_"_$P(F,"__",2,$L(F)+2)
- F Q:$E(F,1)'="_" S F=$E(F,2,$L(F))
- F Q:$E(F,$L(F))'="_" S F=$E(F,1,$L(F)-1)
- S F=$TR(F,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- Q F
- ;
- SEND(IMAGE,DEST,PRI,MECH,LOCATION) N D1,D2,IM,IMG,O,OUT,PRE,RADFN,RADTI,RACNI,RARPT,VRS,X
- S VRS=$$VRS("",$$SEND^MAGBRTUT(IMAGE,DEST,PRI,MECH,LOCATION))
- Q:$G(RULE(RULE,"PRIORSTUDY"))'="YES" VRS
- Q:'$G(IMAGE) VRS
- S X=$G(^MAG(2005,IMAGE,2))
- I $P(X,"^",6)'=74 Q VRS
- S RARPT=$P(X,"^",7) I 'RARPT Q VRS
- S X=$G(^RARPT(RARPT,0)) ; IA # 1171
- S RADFN=$P(X,"^",2),RADTI=9999999.9999-$P(X,"^",3),RACNI=$P(X,"^",4)
- S:RACNI RACNI=$O(^RADPT(+RADFN,"DT",+RADTI,"P","B",RACNI,"")) ; IA # 1172
- S PRE="A^"_RADFN_"^"_RADTI_"^"_RACNI_"^"_RARPT
- D PRIOR1^MAGJEX2(.OUT,PRE)
- S O=0 F S O=$O(OUT(O)) Q:O="" D
- . S X=$G(OUT(O)) Q:'$P(X,"^",2)
- . S X=$P(X,"|",2) Q:'X
- . S RARPT=$P(X,"^",4) Q:'RARPT
- . S D1=0 F S D1=$O(^RARPT(RARPT,2005,D1)) Q:'D1 D ; IA # 1171
- . . S IM=+$G(^RARPT(RARPT,2005,D1,0)) Q:'IM ; IA # 1171
- . . S D2=0 F S D2=$O(^MAG(2005,IM,1,D2)) Q:'D2 D
- . . . S IMG=+$G(^MAG(2005,IM,1,D2,0)) Q:'IMG
- . . . S VRS=$$VRS(VRS,$$SEND^MAGBRTUT(IMG,DEST,PRI,MECH,LOCATION))
- . . . S METMSG(1,"SEND also image #"_IMG_" from prior study")=""
- . . . Q
- . . Q
- . Q
- Q VRS
- ;
- VRS(OLD,NEW) N OUT
- S OUT=""
- S:OLD OUT=OLD_"^"
- S:NEW OUT=OUT_NEW
- F Q:OUT'["^^" S OUT=$P(OUT,"^^",1)_"^"_$P(OUT,"^^",2,$L(OUT)+2)
- Q:$L(OUT)<100 OUT
- Q $P(OUT,"^",1)_"^...^"_$P(OUT,"^",$L(OUT,"^"))
- ;
- LOG(X) N D,H,I,M,T
- S I=$O(^XTMP("MAGEVAL",ZTSK," "),-1)+1
- S XMSG=$G(XMSG)+1 S:I>XMSG XMSG=I
- S D=$P("Thu Fri Sat Sun Mon Tue Wed"," ",$H#7+1)
- S T=$P($H,",",2),H=T\3600,M=T\60#60 S:H<10 H=0_H S:M<10 M=0_M
- S ^XTMP("MAGEVAL",ZTSK,XMSG)=D_" "_H_":"_M_" "_X
- Q
- ;
- WLDMATCH(VAL,WILD) ;
- ;
- ; Returns true if VAL=WILD (Val=Actual value, Wild=Wildcard)
- ;
- ; Wild characters are:
- ; ? matches any single character
- ; * matches any string of characters
- ;
- N I,M
- F Q:VAL="" Q:WILD="" D
- . I $E(VAL,1)=$E(WILD,1) S VAL=$E(VAL,2,$L(VAL)),WILD=$E(WILD,2,$L(WILD)) Q
- . I $E(WILD,1)="?" S VAL=$E(VAL,2,$L(VAL)),WILD=$E(WILD,2,$L(WILD)) Q
- . I $E(WILD,1)="*" D Q:M
- . . I WILD="*" S (VAL,WILD)="",M=1 Q
- . . S WILD=$E(WILD,2,$L(WILD)),M=0
- . . F I=1:1:$L(VAL) I $$WLDMATCH($E(VAL,I,$L(VAL)),WILD) S M=1,VAL=$E(VAL,I,$L(VAL)) Q
- . . Q
- . S VAL="!",WILD=""
- . Q
- Q:VAL'="" 0 Q:WILD'="" 0 Q 1
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGBRTE5 7273 printed Feb 18, 2025@23:25:57 Page 2
- MAGBRTE5 ;WOIFO/PMK - Background Routing - Load Balance ; 06/08/2007 10:28
- +1 ;;3.0;IMAGING;**11,30,51,85,54**;03-July-2009;;Build 1424
- +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 ;; | The Food and Drug Administration classifies this software as |
- +11 ;; | a medical device. As such, it may not be changed in any way. |
- +12 ;; | Modifications to this software may result in an adulterated |
- +13 ;; | medical device under 21CFR820, the use of which is considered |
- +14 ;; | to be a violation of US Federal Statutes. |
- +15 ;; +---------------------------------------------------------------+
- +16 ;;
- +17 QUIT
- +18 ;
- BALANCE(IMAGE,RULE) NEW %,D,DEST,PARENT,PRI,X
- +1 ; ~~~
- SET PARENT=$PIECE(^MAG(2005,IMAGE,0),"^",10)
- +2 if '$DATA(^MAGRT(2006.5906,RULE,1,PARENT))
- Begin DoDot:1
- +3 NEW CP,M1,M2,MAX,B,E,L,RD,T
- +4 ;
- +5 ; Background task must wait for lock
- LOCK +^MAGRT(2006.5906,0):1E9
- +6 ;
- +7 ; Clean up old info
- +8 ; Allow for a study to cross one day boundary,
- +9 ; and remove everything that is older than a day.
- +10 ;
- +11 SET RD=RDT-1
- FOR
- SET RD=$ORDER(^MAGRT(2006.5906,"D",RD),-1)
- if 'RD
- QUIT
- Begin DoDot:2
- +12 NEW DE,RU,PA
- +13 SET DE=""
- FOR
- SET DE=$ORDER(^MAGRT(2006.5906,"D",RD,DE))
- if DE=""
- QUIT
- Begin DoDot:3
- +14 SET RU=""
- FOR
- SET RU=$ORDER(^MAGRT(2006.5906,"D",RD,DE,RU))
- if RU=""
- QUIT
- Begin DoDot:4
- +15 SET PA=""
- FOR
- SET PA=$ORDER(^MAGRT(2006.5906,"D",RD,DE,RU,PA))
- if PA=""
- QUIT
- Begin DoDot:5
- +16 KILL ^MAGRT(2006.5906,"D",RD,DE,RU,PA)
- +17 KILL ^MAGRT(2006.5906,RU,1,PA)
- +18 SET X=^MAGRT(2006.5906,RU,1,0)
- +19 SET $PIECE(X,"^",4)=$PIECE(X,"^",4)-1
- +20 SET ^MAGRT(2006.5906,RU,1,0)=X
- +21 QUIT
- End DoDot:5
- +22 QUIT
- End DoDot:4
- +23 QUIT
- End DoDot:3
- +24 QUIT
- End DoDot:2
- +25 ;
- +26 if '$DATA(^MAGRT(2006.5906,RULE))
- Begin DoDot:2
- +27 SET X=$GET(^MAGRT(2006.5906,0))
- +28 SET $PIECE(X,"^",1,2)="ROUTE LOAD BALANCE^2006.5906"
- +29 if RULE>$PIECE(X,"^",3)
- SET $PIECE(X,"^",3)=RULE
- +30 SET $PIECE(X,"^",4)=$PIECE(X,"^",4)+1
- +31 if RULE>$PIECE(X,"^",3)
- SET $PIECE(X,"^",3)=RULE
- +32 SET ^MAGRT(2006.5906,0)=X
- +33 SET ^MAGRT(2006.5906,RULE,0)=RULE
- +34 QUIT
- End DoDot:2
- +35 ;
- +36 MERGE CP=^MAGRT(2006.5906,"D",RDT)
- +37 SET (B,DEST,L,M1,M2,MAX)=0
- +38 FOR
- SET DEST=$ORDER(RULE(RULE,"ACTION",DEST))
- if 'DEST
- QUIT
- Begin DoDot:2
- +39 NEW I,T
- +40 SET B=B+1
- SET B(B)=DEST
- +41 SET X=RULE(RULE,"ACTION",DEST)
- +42 SET M(B)=$PIECE(X,"^",2)
- SET MAX=MAX+M(B)
- +43 ; Don't exceed maximum number of studies per day days
- +44 SET T=0
- SET I=""
- FOR
- SET I=$ORDER(CP(DEST,I))
- if I=""
- QUIT
- SET T=T+1
- +45 IF $PIECE(X,"^",3)
- IF T'<$PIECE(X,"^",3)
- SET M2=M2+M(B)
- SET M(B)=-1
- SET M1=M1+1
- +46 QUIT
- End DoDot:2
- +47 ; If one destination has reached its cap, redistribute...
- +48 if M1
- Begin DoDot:2
- +49 NEW I,L,R
- +50 SET R=M2#M1
- SET L=0
- +51 FOR I=1:1:B
- if M(I)>0
- SET M(I)=M2\M1+M(I)
- SET L=I
- +52 SET M(L)=M(L)+R
- +53 QUIT
- End DoDot:2
- +54 ;
- +55 SET X=$GET(^MAGRT(2006.5906,RULE,2))
- +56 ; X = LAST ^ TOTAL ^ COUNT(DEST) ^ COUNT(DEST) ^ ...
- +57 FOR L=1:1:B
- SET E(L)=+$PIECE(X,"^",L+2)
- +58 SET L=$PIECE(X,"^",1)
- FOR
- SET L=L+1
- if L>B
- SET L=1
- if E(L)<M(L)
- QUIT
- +59 SET T=$PIECE(X,"^",2)+1
- SET E(L)=E(L)+1
- SET DEST=B(L)
- +60 IF T'<MAX
- SET T=0
- FOR L=1:1:B
- SET E(L)=0
- +61 SET X=L_"^"_T
- FOR L=1:1:B
- SET X=X_"^"_E(L)
- +62 SET ^MAGRT(2006.5906,RULE,2)=X
- +63 ;
- +64 ; Note: on consolidated sites 'origins' and 'destinations'
- +65 ; matter even more than on non-consolidated ones.
- +66 ; In the case of load-balancing, however, the 'destinations'
- +67 ; part is taken care of by the balancing parameters, and the
- +68 ; origin is moot, because each study has one (and only one)
- +69 ; origin.
- +70 ;
- +71 if '$DATA(^MAGRT(2006.5906,RULE,1,PARENT))
- Begin DoDot:2
- +72 SET X=$GET(^MAGRT(2006.5906,RULE,1,0))
- +73 SET $PIECE(X,"^",1,2)="^2006.59061"
- +74 if PARENT>$PIECE(X,"^",3)
- SET $PIECE(X,"^",3)=PARENT
- +75 SET $PIECE(X,"^",4)=$PIECE(X,"^",4)+1
- +76 SET ^MAGRT(2006.5906,RULE,1,0)=X
- +77 SET ^MAGRT(2006.5906,RULE,1,PARENT,0)=PARENT_"^"_RDT_"^"_DEST
- +78 QUIT
- End DoDot:2
- +79 LOCK -^MAGRT(2006.5906,0)
- +80 QUIT
- End DoDot:1
- +81 SET DEST=$PIECE(^MAGRT(2006.5906,RULE,1,PARENT,0),"^",3)
- +82 SET X=$GET(RULE(RULE,"ACTION",DEST))
- +83 IF X=""
- SET METMSG(0,"No location for rule "_RULE_", alternative "_DEST)=""
- QUIT
- +84 SET X=$PIECE(X,"^",1)
- if X="<LOCAL>"
- QUIT
- +85 SET DEST=0
- +86 SET D=0
- FOR
- SET D=$ORDER(RULE(RULE,"ACTION",D))
- if 'D
- QUIT
- Begin DoDot:1
- +87 if $PIECE($GET(RULE(RULE,"ACTION",D)),"^",1)'=X
- QUIT
- +88 SET DEST=D
- +89 QUIT
- End DoDot:1
- if DEST
- QUIT
- +90 IF 'DEST
- SET METMSG(0,"Cannot find location """_X_""".")=""
- QUIT
- +91 SET ^MAGRT(2006.5906,"D",RDT,DEST,RULE,PARENT)=""
- +92 ;
- +93 ; Current version assumes that BALANCE means DOS-Copy, not DICOM...
- +94 DO VALDEST^MAGDRPC1(.DEST,X)
- +95 DO LOG("Load-Balance Destination is "_X)
- +96 SET PRI=$$PRI^MAGBRTE4($GET(RULE(RULE,"PRIORITY")),IMAGE)
- +97 SET VRS=$$VRS(VRS,$$SEND(IMAGE,DEST,PRI,1,LOCATION))
- +98 QUIT
- +99 ;
- VARNAME(F) ;
- +1 SET F=$TRANSLATE(F," !""#$%&'()*+,-./:;<=>?@[\]^_`{|}~","_________________________________")
- +2 FOR
- if F'["__"
- QUIT
- SET F=$PIECE(F,"__",1)_"_"_$PIECE(F,"__",2,$LENGTH(F)+2)
- +3 FOR
- if $EXTRACT(F,1)'="_"
- QUIT
- SET F=$EXTRACT(F,2,$LENGTH(F))
- +4 FOR
- if $EXTRACT(F,$LENGTH(F))'="_"
- QUIT
- SET F=$EXTRACT(F,1,$LENGTH(F)-1)
- +5 SET F=$TRANSLATE(F,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- +6 QUIT F
- +7 ;
- SEND(IMAGE,DEST,PRI,MECH,LOCATION) NEW D1,D2,IM,IMG,O,OUT,PRE,RADFN,RADTI,RACNI,RARPT,VRS,X
- +1 SET VRS=$$VRS("",$$SEND^MAGBRTUT(IMAGE,DEST,PRI,MECH,LOCATION))
- +2 if $GET(RULE(RULE,"PRIORSTUDY"))'="YES"
- QUIT VRS
- +3 if '$GET(IMAGE)
- QUIT VRS
- +4 SET X=$GET(^MAG(2005,IMAGE,2))
- +5 IF $PIECE(X,"^",6)'=74
- QUIT VRS
- +6 SET RARPT=$PIECE(X,"^",7)
- IF 'RARPT
- QUIT VRS
- +7 ; IA # 1171
- SET X=$GET(^RARPT(RARPT,0))
- +8 SET RADFN=$PIECE(X,"^",2)
- SET RADTI=9999999.9999-$PIECE(X,"^",3)
- SET RACNI=$PIECE(X,"^",4)
- +9 ; IA # 1172
- if RACNI
- SET RACNI=$ORDER(^RADPT(+RADFN,"DT",+RADTI,"P","B",RACNI,""))
- +10 SET PRE="A^"_RADFN_"^"_RADTI_"^"_RACNI_"^"_RARPT
- +11 DO PRIOR1^MAGJEX2(.OUT,PRE)
- +12 SET O=0
- FOR
- SET O=$ORDER(OUT(O))
- if O=""
- QUIT
- Begin DoDot:1
- +13 SET X=$GET(OUT(O))
- if '$PIECE(X,"^",2)
- QUIT
- +14 SET X=$PIECE(X,"|",2)
- if 'X
- QUIT
- +15 SET RARPT=$PIECE(X,"^",4)
- if 'RARPT
- QUIT
- +16 ; IA # 1171
- SET D1=0
- FOR
- SET D1=$ORDER(^RARPT(RARPT,2005,D1))
- if 'D1
- QUIT
- Begin DoDot:2
- +17 ; IA # 1171
- SET IM=+$GET(^RARPT(RARPT,2005,D1,0))
- if 'IM
- QUIT
- +18 SET D2=0
- FOR
- SET D2=$ORDER(^MAG(2005,IM,1,D2))
- if 'D2
- QUIT
- Begin DoDot:3
- +19 SET IMG=+$GET(^MAG(2005,IM,1,D2,0))
- if 'IMG
- QUIT
- +20 SET VRS=$$VRS(VRS,$$SEND^MAGBRTUT(IMG,DEST,PRI,MECH,LOCATION))
- +21 SET METMSG(1,"SEND also image #"_IMG_" from prior study")=""
- +22 QUIT
- End DoDot:3
- +23 QUIT
- End DoDot:2
- +24 QUIT
- End DoDot:1
- +25 QUIT VRS
- +26 ;
- VRS(OLD,NEW) NEW OUT
- +1 SET OUT=""
- +2 if OLD
- SET OUT=OLD_"^"
- +3 if NEW
- SET OUT=OUT_NEW
- +4 FOR
- if OUT'["^^"
- QUIT
- SET OUT=$PIECE(OUT,"^^",1)_"^"_$PIECE(OUT,"^^",2,$LENGTH(OUT)+2)
- +5 if $LENGTH(OUT)<100
- QUIT OUT
- +6 QUIT $PIECE(OUT,"^",1)_"^...^"_$PIECE(OUT,"^",$LENGTH(OUT,"^"))
- +7 ;
- LOG(X) NEW D,H,I,M,T
- +1 SET I=$ORDER(^XTMP("MAGEVAL",ZTSK," "),-1)+1
- +2 SET XMSG=$GET(XMSG)+1
- if I>XMSG
- SET XMSG=I
- +3 SET D=$PIECE("Thu Fri Sat Sun Mon Tue Wed"," ",$HOROLOG#7+1)
- +4 SET T=$PIECE($HOROLOG,",",2)
- SET H=T\3600
- SET M=T\60#60
- if H<10
- SET H=0_H
- if M<10
- SET M=0_M
- +5 SET ^XTMP("MAGEVAL",ZTSK,XMSG)=D_" "_H_":"_M_" "_X
- +6 QUIT
- +7 ;
- WLDMATCH(VAL,WILD) ;
- +1 ;
- +2 ; Returns true if VAL=WILD (Val=Actual value, Wild=Wildcard)
- +3 ;
- +4 ; Wild characters are:
- +5 ; ? matches any single character
- +6 ; * matches any string of characters
- +7 ;
- +8 NEW I,M
- +9 FOR
- if VAL=""
- QUIT
- if WILD=""
- QUIT
- Begin DoDot:1
- +10 IF $EXTRACT(VAL,1)=$EXTRACT(WILD,1)
- SET VAL=$EXTRACT(VAL,2,$LENGTH(VAL))
- SET WILD=$EXTRACT(WILD,2,$LENGTH(WILD))
- QUIT
- +11 IF $EXTRACT(WILD,1)="?"
- SET VAL=$EXTRACT(VAL,2,$LENGTH(VAL))
- SET WILD=$EXTRACT(WILD,2,$LENGTH(WILD))
- QUIT
- +12 IF $EXTRACT(WILD,1)="*"
- Begin DoDot:2
- +13 IF WILD="*"
- SET (VAL,WILD)=""
- SET M=1
- QUIT
- +14 SET WILD=$EXTRACT(WILD,2,$LENGTH(WILD))
- SET M=0
- +15 FOR I=1:1:$LENGTH(VAL)
- IF $$WLDMATCH($EXTRACT(VAL,I,$LENGTH(VAL)),WILD)
- SET M=1
- SET VAL=$EXTRACT(VAL,I,$LENGTH(VAL))
- QUIT
- +16 QUIT
- End DoDot:2
- if M
- QUIT
- +17 SET VAL="!"
- SET WILD=""
- +18 QUIT
- End DoDot:1
- +19 if VAL'=""
- QUIT 0
- if WILD'=""
- QUIT 0
- QUIT 1
- +20 ;
