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 Apr 09, 2024@21:10:49 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 ;
