INHDIPZ3.m

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       ;