INHDIA3 ;GFT,JSH; 6 May 91 13:03
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
;
X ;
I 'Y S:'DSC&DB DB=DB+1 F Y=0:0 S Y=$O(Y(Y)) G 2^INHDIA:Y="" D D^INHDIA
S Y=X G B:Y'[";" I Y?.E1";"1L.E F D=97:1:122 S %=$F(Y,";"_$C(D)) I % S Y=$E(Y,1,%-2)_$C(D-32)_$E(Y,%,999)
S X=$P(Y,";",2,9),DK=$P(X,";",2,9),DRS=99,D=$E(X),%=$P(X,";") S:DK]"" DK=";"_DK S:%["//" $P(Y,";")=$P(Y,";")_"//"_$P(%,"//",2,9),$P(X,";")=$P(%,"//")
I D="U" S $P(DV,"//")=$P(DV,"//")_U_% G BACK
S D=$S(D="N":D,D="F":D,D="T":2,D="""":$F(X,D,2),1:0) I 'D S D=$S(D'=0:D,X[";":$F(X,";")-1,1:999) S:'D $P(DV,"//")=$P(DV,"//")_U_D,D=2
E S %=$S(D=2:"T",1:$E(X,2,D-2)) G DIA3^DIQQQ:$A(%)>45&($A(%)<58)!(%[":") S DV=%_DV
S DK=$E(X,D,999)
BACK S X=$P(Y,";")_DK S:'$D(DIAB) DIAB=Y G DIC^INHDIA
;
B I X'?.E1":",X[" ",DUZ(0)="@" D ^DIM G P:$D(X)=1
DF F DK="///+","//+","///","//" I Y[DK S DP=$P(Y,DK,2,9) I DP'?1"/".E&(DP'?1"^".E)!(DUZ(0)="@") G DEF
G BAD:Y'?.E1":"
E K X S:'$D(DIAB) DIAB=Y S DIA3=$P($P($G(DIAT),";",DB),U,4),DICOMP=L_$E("L",DIA3["L")_$E(2,DIA3["A")_$E("N",DIA3["N")_"WE?",DQI="Y(",DA="DR(99,"_DXS_",",X=Y,DICMX=1 D ^DICOMPW I '$D(X) K DIAB G BAD
I $D(X)>1 S DXS=DXS+1 F %=0:0 S %=$O(X(%)) Q:'% S @(DA_"%)=X(%)")
S %=2 I Y["E" S %=2-(DIA3["M") W:$X ! W "Having entered data for one '"_$E(DIAB,1,$L(DIAB)-1)_"' ENTRY,",!?9,"shall user be asked another" D YN^DICN I %<1 K DIAB G BAD
S L=$S(Y>L:+Y,1:L\100+1*100),Y=U_DP_U_$E("M",%)_$E("L",Y["L")_$E("A",Y["A")_$E("N",Y'["E")_U_X_" S X=$S(D(0)>0:D(0),1:"""")",DRS=99 K X D DB^INHDIA S X=DI,DI=+DP G EN^INHDIA
;
DEF S DIA3=Y,X="DA,DV,DWLC,0)=X" F J=L:-1 Q:I(J)[U S X="DA("_(L-J+1)_"),"_I(J)_","_X
I $L(DP)>1!(DP="@") S DICMX="S DWLC=DWLC+1,"_DIA_X,DA="DR(99,"_DXS_",",X=DP,DQI="X(",DICOMP=L_"T?" D EN^DICOMP,DICS^INHDIA,XEC
K X S X=$P(DIA3,DK),DV=DV_DK_DP G DIC^INHDIA:DV'[";"
BAD G X^INHDIA
;
XEC I $D(X),Y["m" S DIC("S")="S %=$P(^(0),U,2) I %,$D(^DD(+%,.01,0)),$P(^(0),U,2)[""W"",$D(^DD(DI,Y,0)) "_DIC("S")
F Y=0:0 S Y=$O(X(Y)) Q:Y="" S @(DA_"Y)=X(Y)")
I $D(X) S %=1,Y="Do you mean '"_DP_"' as a variable" W !?63-$L(Y),Y D YN^DICN Q:%-1 S Y="Q",DXS=DXS+1,DP=U_X,DRS=99 D D^INHDIA:$S(DIAP:$P(DR(DIAR,DI),";",DIAP#1000)'="Q",1:1) S:'$D(DIAB) DIAB=DIA3
Q:DP'="@" I DK="//" S DA=U_U Q
Q
;
AT ;
S DIAB=X I X?1P1N.N1";"1E.E S X=$P(X,";") G P
K X S X=$P($E(DIAB,2,999),";"),DICOMP=L_"T?",DQI="X(",DA="DR(99,"_DXS_","
D EN^DICOMP,DICS^INHDIA G BAD:'$D(X)
S DXS=DXS+1,X=X_" K Y" F Y=0:0 S Y=$O(X(Y)) Q:Y="" S @(DA_"Y)=X(Y)") K X(Y)
P G P^INHDIA
INHDIA3 ;GFT,JSH; 6 May 91 13:03
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 ;
X ;
+1 IF 'Y
IF 'DSC&DB
SET DB=DB+1
FOR Y=0:0
SET Y=$ORDER(Y(Y))
IF Y=""
GOTO 2^INHDIA
DO D^INHDIA
+2 SET Y=X
IF Y'[";"
GOTO B
IF Y?.E1";"1L.E
FOR D=97:1:122
SET %=$FIND(Y,";"_$CHAR(D))
IF %
SET Y=$EXTRACT(Y,1,%-2)_$CHAR(D-32)_$EXTRACT(Y,%,999)
+3 SET X=$PIECE(Y,";",2,9)
SET DK=$PIECE(X,";",2,9)
SET DRS=99
SET D=$EXTRACT(X)
SET %=$PIECE(X,";")
IF DK]""
SET DK=";"_DK
IF %["//"
SET $PIECE(Y,";")=$PIECE(Y,";")_"//"_$PIECE(%,"//",2,9)
SET $PIECE(X,";")=$PIECE(%,"//")
+4 IF D="U"
SET $PIECE(DV,"//")=$PIECE(DV,"//")_U_%
GOTO BACK
+5 SET D=$SELECT(D="N":D,D="F":D,D="T":2,D="""":$FIND(X,D,2),1:0)
IF 'D
SET D=$SELECT(D'=0:D,X[";":$FIND(X,";")-1,1:999)
IF 'D
SET $PIECE(DV,"//")=$PIECE(DV,"//")_U_D
SET D=2
+6 IF '$TEST
SET %=$SELECT(D=2:"T",1:$EXTRACT(X,2,D-2))
IF $ASCII(%)>45&($ASCII(%)<58)!(%[":")
GOTO DIA3^DIQQQ
SET DV=%_DV
+7 SET DK=$EXTRACT(X,D,999)
BACK SET X=$PIECE(Y,";")_DK
IF '$DATA(DIAB)
SET DIAB=Y
GOTO DIC^INHDIA
+1 ;
B IF X'?.E1":"
IF X[" "
IF DUZ(0)="@"
DO ^DIM
IF $DATA(X)=1
GOTO P
DF FOR DK="///+","//+","///","//"
IF Y[DK
SET DP=$PIECE(Y,DK,2,9)
IF DP'?1"/".E&(DP'?1"^".E)!(DUZ(0)="@")
GOTO DEF
+1 IF Y'?.E1":"
GOTO BAD
E KILL X
IF '$DATA(DIAB)
SET DIAB=Y
SET DIA3=$PIECE($PIECE($GET(DIAT),";",DB),U,4)
SET DICOMP=L_$EXTRACT("L",DIA3["L")_$EXTRACT(2,DIA3["A")_$EXTRACT("N",DIA3["N")_"WE?"
SET DQI="Y("
SET DA="DR(99,"_DXS_","
SET X=Y
SET DICMX=1
DO ^DICOMPW
IF '$DATA(X)
KILL DIAB
GOTO BAD
+1 IF $DATA(X)>1
SET DXS=DXS+1
FOR %=0:0
SET %=$ORDER(X(%))
IF '%
QUIT
SET @(DA_"%)=X(%)")
+2 SET %=2
IF Y["E"
SET %=2-(DIA3["M")
IF $X
WRITE !
WRITE "Having entered data for one '"_$EXTRACT(DIAB,1,$LENGTH(DIAB)-1)_"' ENTRY,",!?9,"shall user be asked another"
DO YN^DICN
IF %<1
KILL DIAB
GOTO BAD
+3 SET L=$SELECT(Y>L:+Y,1:L\100+1*100)
SET Y=U_DP_U_$EXTRACT("M",%)_$EXTRACT("L",Y["L")_$EXTRACT("A",Y["A")_$EXTRACT("N",Y'["E")_U_X_" S X=$S(D(0)>0:D(0),1:"""")"
SET DRS=99
KILL X
DO DB^INHDIA
SET X=DI
SET DI=+DP
GOTO EN^INHDIA
+4 ;
DEF SET DIA3=Y
SET X="DA,DV,DWLC,0)=X"
FOR J=L:-1
IF I(J)[U
QUIT
SET X="DA("_(L-J+1)_"),"_I(J)_","_X
+1 IF $LENGTH(DP)>1!(DP="@")
SET DICMX="S DWLC=DWLC+1,"_DIA_X
SET DA="DR(99,"_DXS_","
SET X=DP
SET DQI="X("
SET DICOMP=L_"T?"
DO EN^DICOMP
DO DICS^INHDIA
DO XEC
+2 KILL X
SET X=$PIECE(DIA3,DK)
SET DV=DV_DK_DP
IF DV'[";"
GOTO DIC^INHDIA
BAD GOTO X^INHDIA
+1 ;
XEC IF $DATA(X)
IF Y["m"
SET DIC("S")="S %=$P">P(^(0),U,2) I %,$D(^DD(+%,.01,0)),$P">P(^(0),U,2)[""W"",$D(^DD(DI,Y,0)) "_DIC("S")
+1 FOR Y=0:0
SET Y=$ORDER(X(Y))
IF Y=""
QUIT
SET @(DA_"Y)=X(Y)")
+2 IF $DATA(X)
SET %=1
SET Y="Do you mean '"_DP_"' as a variable"
WRITE !?63-$LENGTH(Y),Y
DO YN^DICN
IF %-1
QUIT
SET Y="Q"
SET DXS=DXS+1
SET DP=U_X
SET DRS=99
IF $SELECT(DIAP:$PIECE(DR(DIAR,DI),";",DIAP#1000)'="Q",1:1)
DO D^INHDIA
IF '$DATA(DIAB)
SET DIAB=DIA3
+3 IF DP'="@"
QUIT
IF DK="//"
SET DA=U_U
QUIT
+4 QUIT
+5 ;
AT ;
+1 SET DIAB=X
IF X?1P1N.N1";"1E.E
SET X=$PIECE(X,";")
GOTO P
+2 KILL X
SET X=$PIECE($EXTRACT(DIAB,2,999),";")
SET DICOMP=L_"T?"
SET DQI="X("
SET DA="DR(99,"_DXS_","
+3 DO EN^DICOMP
DO DICS^INHDIA
IF '$DATA(X)
GOTO BAD
+4 SET DXS=DXS+1
SET X=X_" K Y"
FOR Y=0:0
SET Y=$ORDER(X(Y))
IF Y=""
QUIT
SET @(DA_"Y)=X(Y)")
KILL X(Y)
P GOTO P^INHDIA
