INHDIPZ3 ;JSH; 8 Apr 94 17:02;Modify FileMan generated code.
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
;
MOD(G,%WRT,%YS,%DREF,%START,%END) ;
;Scan through @G array and modify the Write statements
;%WRT = Write messages (0 = NO, 1:default = YES)
;%YS = Substitute $Y references (0 = NO, 1:default = YES)
;%DREF = Routine which all non-specific DOs are invoked from
;%START = starting node (default: first)
;%END = ending node (default: last)
S:'$D(%WRT) %WRT=1 S:'$D(%YS) %YS=1 S:'$D(%END) %END=99999
N C,CL,CL1,COND,DE,F,FP,I,J,L,LZ,NL,P,P1,P2,P3,PAR,PC,Q,QS,WE,Z
S Q=""""
S I=$G(%START)-.00001 F S I=$O(@G@(I)) Q:'I Q:I>%END S L=^(I) D S @G@(I)=L
. S P=1,QS=0 W:%WRT "."
. F D Q:P'<$L(L) S P=P+1
.. I $E(L,P)=Q S QS='QS Q
.. Q:QS
.. I $E(L,P,P+2)=" D " S Z=L K L S L=Z D DO(.L,.P),LFIX Q
.. I $E(L,P,P+1)="$Y" S L=$E(L,1,P-1)_$S(%YS:"INL",1:0)_$E(L,P+2,999),P=P+2 Q
.. I $E(L,P,P+1)="$X" S L=$E(L,1,P-1)_"INP"_$E(L,P+2,999),P=P+2 Q
.. I $E(L,P,P+2)=" W " S Z=L K L S L=Z D W(.L,.P,0),LFIX Q
.. I $E(L,P,P+2)=" W:" S Z=L K L S L=Z D W(.L,.P,1),LFIX Q
Q
;
LFIX ;Reset lines
F J=0:1 Q:'$D(L(J)) S @G@(J/100+I)=L(J),L=L(J)
S I=J-1/100+I Q
;
DO(%L,%P) ;Convert a DO statement
;%L = line of code
;%P = position
N I,P2,C,LZ
S LZ=0,%L(LZ)=$E(%L,1,%P-1)
S P2=$$ENDW(%L,%P+3," "),DE=$E(%L,%P+3,P2) Q:DE=""
F PC=1:1:$L(DE,",") D
. S C=$P(DE,",",PC),P3=$$ENDW(C,1,":"),C=$E(C,1,P3),COND=$E($P(DE,",",PC),P3+1,999) D CONDSET:COND]""
. I C["^DIWW" S NL=" D "_$P(C,"^")_"^DIWWA" D SET Q
. I $G(%DREF)]"" S F=0 D Q:F
.. F I=1:1:$L(%DREF,",") I $P($P(%DREF,",",I),";")=C S NL=" D "_$P($P(%DREF,",",I),";",2)_COND D SET S F=1 Q
. S NL=" D "_C_COND D SET Q
I $L($E(%L,P2+1,999)) S LZ=LZ+1,%L(LZ)=$E(%L,P2+1,999),%P=0
Q
;
CONDSET ;Check for $X and $Y in COND
N P,P1 S P=0
F S P1=$F(COND,"$X",P) S:'P1 P1=$F(COND,"$Y",P) Q:'P1 D
. S COND=$E(COND,1,P1-3)_$P("INP^INP^0^INL",U,$E(COND,P1-1)="Y"+1+%YS)_$E(COND,P1,999),P=P1+1
Q
;
W(%L,%P,%I) ;Convert Write statements
; %L = Line of code
; %P = Starting position of ' W '
; %I = condition present (0:default = NO, 1 = YES)
N P2,WE,QS,CL,NL,Q,PC,LZ,COND,P1 S %I=+$G(%I),COND=""
S %L(0)=$E(%L,1,%P-1)
I %I S P1=$$ENDW(%L,%P+1," "),COND=$E(%L,%P+2,P1),%P=P1-1
S P2=$$ENDW(%L,%P+3," "),WE=$E(%L,%P+3,P2) Q:P2=""
D:COND]"" CONDSET
S PC=1,CL="",(PAR,QS,LZ)=0,Q="""" F PC=1:1:$L(WE) D
. I $E(WE,PC)=Q S QS='QS
. I 'QS,"()"[$E(WE,PC) S PAR=PAR+$P("1^-1",U,$E(WE,PC)=")"+1)
. I " ,"'[$E(WE,PC)!QS!PAR S CL=CL_$E(WE,PC) Q:PC'=$L(WE)
. Q:QS!PAR
. I CL="!" S NL=" S"_COND_" INL=INL+1,INP=0,@INV@(INL)=""""" D SET Q
. I CL?1"?"1.N S NL=" S"_COND_" INP0=INP,@INV@(INL)=$G(@INV@(INL))_$J("""","_+$P(CL,"?",2)_"-INP),INP=$S("_+$P(CL,"?",2)_"<INP0:INP0,1:"_+$P(CL,"?",2)_")" D SET Q
. I $L(CL)>90 S NL=" S"_COND_" @INV@(INL)=$G(@INV@(INL))_"_CL S CL1=CL D SET S NL=" S"_COND_" INP=INP+$L("_CL1_")" D SET Q
. S NL=" S"_COND_" @INV@(INL)=$G(@INV@(INL))_"_CL_",INP=INP+$L("_CL_")" D SET Q
I $L($E(%L,P2+1,999)) S LZ=LZ+1,%L(LZ)=$E(%L,P2+1,999),%P=0
Q
;
SET ;Set new info in place
I $L(%L(LZ))+$L(NL)<240 S %L(LZ)=%L(LZ)_NL,%P=$L(%L(LZ))+1 S CL="" Q
S LZ=LZ+1,%L(LZ)=NL,%P=$L(NL)+1
S CL="" Q
;
WP ;Word Processing
S NL=" S LM=$O(^UTILITY($J,""W"",0)) I LM]"""" F I=0:0 S I=$O(^UTILITY($J,""W"",LM,I)) Q:'I S X=^(I,0) S @INV@(INL)=@INV@(INL)_$J("""",LM-INP-1)_X D N" D SET
S LZ=LZ+1,%L(LZ)="",NL=" K ^UTILITY($J,""W"")" D SET
I $L($E(%L,P2+1,999)) S LZ=LZ+1,%L(LZ)=$E(%L,P2+1,999),%P=0
Q
;
ENDW(%L,%P,%TERM) ;Find end of a statement and return it
N QS,Q,P,FP
S QS=0,Q="""",FP=0
F P=%P:1:$L(%L) D Q:FP
. I $E(%L,P)=Q S QS='QS
. Q:QS
. S:%TERM[$E(%L,P) FP=P
Q $S(FP:FP-1,1:$L(%L))
;
INHDIPZ3 ;JSH; 8 Apr 94 17:02;Modify FileMan generated code.
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 ;
MOD(G,%WRT,%YS,%DREF,%START,%END) ;
+1 ;Scan through @G array and modify the Write statements
+2 ;%WRT = Write messages (0 = NO, 1:default = YES)
+3 ;%YS = Substitute $Y references (0 = NO, 1:default = YES)
+4 ;%DREF = Routine which all non-specific DOs are invoked from
+5 ;%START = starting node (default: first)
+6 ;%END = ending node (default: last)
+7 IF '$DATA(%WRT)
SET %WRT=1
IF '$DATA(%YS)
SET %YS=1
IF '$DATA(%END)
SET %END=99999
+8 NEW C,CL,CL1,COND,DE,F,FP,I,J,L,LZ,NL,P,P1,P2,P3,PAR,PC,Q,QS,WE,Z
+9 SET Q=""""
+10 SET I=$GET(%START)-.00001
FOR
SET I=$ORDER(@G@(I))
IF 'I
QUIT
IF I>%END
QUIT
SET L=^(I)
Begin DoDot:1
+11 SET P=1
SET QS=0
IF %WRT
WRITE "."
+12 FOR
Begin DoDot:2
+13 IF $EXTRACT(L,P)=Q
SET QS='QS
QUIT
+14 IF QS
QUIT
+15 IF $EXTRACT(L,P,P+2)=" D "
SET Z=L
KILL L
SET L=Z
DO DO(.L,.P)
DO LFIX
QUIT
+16 IF $EXTRACT(L,P,P+1)="$Y"
SET L=$EXTRACT(L,1,P-1)_$SELECT(%YS:"INL",1:0)_$EXTRACT(L,P+2,999)
SET P=P+2
QUIT
+17 IF $EXTRACT(L,P,P+1)="$X"
SET L=$EXTRACT(L,1,P-1)_"INP"_$EXTRACT(L,P+2,999)
SET P=P+2
QUIT
+18 IF $EXTRACT(L,P,P+2)=" W "
SET Z=L
KILL L
SET L=Z
DO W(.L,.P,0)
DO LFIX
QUIT
+19 IF $EXTRACT(L,P,P+2)=" W:"
SET Z=L
KILL L
SET L=Z
DO W(.L,.P,1)
DO LFIX
QUIT
End DoDot:2
IF P'<$LENGTH(L)
QUIT
SET P=P+1
End DoDot:1
SET @G@(I)=L
+20 QUIT
+21 ;
LFIX ;Reset lines
+1 FOR J=0:1
IF '$DATA(L(J))
QUIT
SET @G@(J/100+I)=L(J)
SET L=L(J)
+2 SET I=J-1/100+I
QUIT
+3 ;
DO(%L,%P) ;Convert a DO statement
+1 ;%L = line of code
+2 ;%P = position
+3 NEW I,P2,C,LZ
+4 SET LZ=0
SET %L(LZ)=$EXTRACT(%L,1,%P-1)
+5 SET P2=$$ENDW(%L,%P+3," ")
SET DE=$EXTRACT(%L,%P+3,P2)
IF DE=""
QUIT
+6 FOR PC=1:1:$LENGTH(DE,",")
Begin DoDot:1
+7 SET C=$PIECE(DE,",",PC)
SET P3=$$ENDW(C,1,":")
SET C=$EXTRACT(C,1,P3)
SET COND=$EXTRACT($PIECE(DE,",",PC),P3+1,999)
IF COND]""
DO CONDSET
+8 IF C["^DIWW"
SET NL=" D "_$PIECE(C,"^")_"^DIWWA"
DO SET
QUIT
+9 IF $GET(%DREF)]""
SET F=0
Begin DoDot:2
+10 FOR I=1:1:$LENGTH(%DREF,",")
IF $PIECE($PIECE(%DREF,",",I),";")=C
SET NL=" D "_$PIECE($PIECE(%DREF,",",I),";",2)_COND
DO SET
SET F=1
QUIT
End DoDot:2
IF F
QUIT
+11 SET NL=" D "_C_COND
DO SET
QUIT
End DoDot:1
+12 IF $LENGTH($EXTRACT(%L,P2+1,999))
SET LZ=LZ+1
SET %L(LZ)=$EXTRACT(%L,P2+1,999)
SET %P=0
+13 QUIT
+14 ;
CONDSET ;Check for $X and $Y in COND
+1 NEW P,P1
SET P=0
+2 FOR
SET P1=$FIND(COND,"$X",P)
IF 'P1
SET P1=$FIND(COND,"$Y",P)
IF 'P1
QUIT
Begin DoDot:1
+3 SET COND=$EXTRACT(COND,1,P1-3)_$PIECE("INP^INP^0^INL",U,$EXTRACT(COND,P1-1)="Y"+1+%YS)_$EXTRACT(COND,P1,999)
SET P=P1+1
End DoDot:1
+4 QUIT
+5 ;
W(%L,%P,%I) ;Convert Write statements
+1 ; %L = Line of code
+2 ; %P = Starting position of ' W '
+3 ; %I = condition present (0:default = NO, 1 = YES)
+4 NEW P2,WE,QS,CL,NL,Q,PC,LZ,COND,P1
SET %I=+$GET(%I)
SET COND=""
+5 SET %L(0)=$EXTRACT(%L,1,%P-1)
+6 IF %I
SET P1=$$ENDW(%L,%P+1," ")
SET COND=$EXTRACT(%L,%P+2,P1)
SET %P=P1-1
+7 SET P2=$$ENDW(%L,%P+3," ")
SET WE=$EXTRACT(%L,%P+3,P2)
IF P2=""
QUIT
+8 IF COND]""
DO CONDSET
+9 SET PC=1
SET CL=""
SET (PAR,QS,LZ)=0
SET Q=""""
FOR PC=1:1:$LENGTH(WE)
Begin DoDot:1
+10 IF $EXTRACT(WE,PC)=Q
SET QS='QS
+11 IF 'QS
IF "()"[$EXTRACT(WE,PC)
SET PAR=PAR+$PIECE("1^-1",U,$EXTRACT(WE,PC)=")"+1)
+12 IF " ,"'[$EXTRACT(WE,PC)!QS!PAR
SET CL=CL_$EXTRACT(WE,PC)
IF PC'=$LENGTH(WE)
QUIT
+13 IF QS!PAR
QUIT
+14 IF CL="!"
SET NL=" S"_COND_" INL=INL+1,INP=0,@INV@(INL)="""""
DO SET
QUIT
+15 IF CL?1"?"1.N
SET NL=" S"_COND_" INP0=INP,@INV@(INL)=$G(@INV@(INL))_$J("""","_+$PIECE(CL,"?",2)_"-INP),INP=$S("_+$PIECE(CL,"?",2)_"<INP0:INP0,1:"_+$PIECE(CL,"?",2)_")"
DO SET
QUIT
+16 IF $LENGTH(CL)>90
SET NL=" S"_COND_" @INV@(INL)=$G(@INV@(INL))_"_CL
SET CL1=CL
DO SET
SET NL=" S"_COND_" INP=INP+$L("_CL1_")"
DO SET
QUIT
+17 SET NL=" S"_COND_" @INV@(INL)=$G(@INV@(INL))_"_CL_",INP=INP+$L("_CL_")"
DO SET
QUIT
End DoDot:1
+18 IF $LENGTH($EXTRACT(%L,P2+1,999))
SET LZ=LZ+1
SET %L(LZ)=$EXTRACT(%L,P2+1,999)
SET %P=0
+19 QUIT
+20 ;
SET ;Set new info in place
+1 IF $LENGTH(%L(LZ))+$LENGTH(NL)<240
SET %L(LZ)=%L(LZ)_NL
SET %P=$LENGTH(%L(LZ))+1
SET CL=""
QUIT
+2 SET LZ=LZ+1
SET %L(LZ)=NL
SET %P=$LENGTH(NL)+1
+3 SET CL=""
QUIT
+4 ;
WP ;Word Processing
+1 SET NL=" S LM=$O(^UTILITY($J,""W"",0)) I LM]"""" F I=0:0 S I=$O(^UTILITY($J,""W"",LM,I)) Q:'I S X=^(I,0) S @INV@(INL)=@INV@(INL)_$J("""",LM-INP-1)_X D N"
DO SET
+2 SET LZ=LZ+1
SET %L(LZ)=""
SET NL=" K ^UTILITY($J,""W"")"
DO SET
+3 IF $LENGTH($EXTRACT(%L,P2+1,999))
SET LZ=LZ+1
SET %L(LZ)=$EXTRACT(%L,P2+1,999)
SET %P=0
+4 QUIT
+5 ;
ENDW(%L,%P,%TERM) ;Find end of a statement and return it
+1 NEW QS,Q,P,FP
+2 SET QS=0
SET Q=""""
SET FP=0
+3 FOR P=%P:1:$LENGTH(%L)
Begin DoDot:1
+4 IF $EXTRACT(%L,P)=Q
SET QS='QS
+5 IF QS
QUIT
+6 IF %TERM[$EXTRACT(%L,P)
SET FP=P
End DoDot:1
IF FP
QUIT
+7 QUIT $SELECT(FP:FP-1,1:$LENGTH(%L))
+8 ;
