- INHDIA(%T,%F) ;GFT,JSH; 16 Nov 95 16:22;Generic Interface - create an Input Template
- ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
- ;COPYRIGHT 1991-2000 SAIC
- ;
- ;%T = name of template
- ;%F = file number^global reference
- ;Enter with ^UTILITY("INDIA",$J,n) [n=1,2,3...] containing the lines for the template
- ;
- S DIC=U_$P(%F,U,2) N T S:'$D(DMAX) DMAX=$G(^DD("ROU")) S:'DMAX DMAX=4000
- S DIA=DIC,DI=+%F,(J(0),DIA("P"))=DI,DIA("DIET")=$G(^DIC(DI,0,"DIET"))
- D QQ S DR="",(DIEFMT,L,DIAR,DRS,DIAP,DB,DSC)=0,F=-1,I(0)=DIA,DXS=1 D EN
- Q:'$O(^UTILITY("INDIA",$J,0))
- S INI=0 F S INI=$O(^UTILITY("INDIA",$J,INI)) Q:'INI S X=^(INI) W:'(INI#5) "." D L
- F Q:'F D UP
- STORE ;Store the template
- F F=0:0 S F=$O(^UTILITY($J,"OV",F)) Q:'F F X=0:0 S X=$O(^UTILITY($J,"OV",F,X)) Q:'X S DW=DR(F,X),DR(F,X)=^(X,0),I=1 D OV
- G S
- ;
- OV I '$D(^(I)) S DR(F,X,I)=DW Q
- S DR(F,X,I)=^(I),I=I+1 G OV
- ;
- S S DIC="^DIE(",DIC(0)="LZ",DIC("S")="I $P(^(0),U,4)="_+%F,D="F"_+%F,X=%T D IX^DIC K DIC S %=$P(Y,U,3)
- L +^DIE K ^DIE(+Y) S ^(+Y,0)=X_U_DT_U_"@"_U_+%F_U_U_"@",^DIE("F"_+%F,X,+Y)=1 L -^DIE K ^UTILITY($J,"OV")
- M ^DIE(+Y,"DR")=DR,^DIE(+Y,"DIAB")=^UTILITY($J)
- S X=%T D EN^DIEZ
- ;
- Q K DI,DLAYGO,DIA,I,J
- QQ K ^UTILITY($J),DICHK,DIAT,DIART,DIAR,DIAB,DIAO,DIAP,DIAA,IOP,DSC,DIA3,DHIT,DRS,DIE,DR,DA,DG,DIC,F,DP,DQ,DV,DB,DW,D,X,Y,L Q
- 1 Q
- L K DIC,DIAB,DIAM S DSC=X?1"^".E I DSC S X=$E(X,2,999) I U[X K DR Q
- I $A(X)=64 G AT^INHDIA3:X'?1P.N,P:$L(X)>1,X:'DB S DB=DB+1 G 2
- D DICS S DV="",J=$P(X,"-",2)
- DIC ;
- K Y S DIC(0)="Z",DIC="^DD(DI," D ^DIC
- I Y>0 D SET S Y=$P(Y(0),U,2) G 2:'Y S X=DI,L=L+1,(DI,J(L))=+Y,I(L)=""""_$P($P(Y(0),U,4),";")_"""" G DOWN
- F D=124,93 I $A(X)=D S:D=124 DIAB=X,DIAM=1 S DRS=9,X=$E(X,2,999) G DIC:X]"",UP
- S DIC(0)="Y",D="GR" I $D(^DD(DI,D)) D IX^DIC I Y>0 D SET G 2
- G X^INHDIA3
- ;
- F S X=$P(^DD(DI,0),U) I F,X="FIELD" S X=$O(^(0,"NM",0))_" "_X
- Q
- ;
- X ;
- W !,*7,"Field: '"_$P(^UTILITY("INDIA",$J,INI),"///")_"' is invalid in template. (It may be COMPUTED)" K Y D DICS
- 2 ;
- Q
- UP ;
- Q:'F
- K I(L),J(L) S L=L-1 I '$D(J(L)) F L=L-99:1 Q:'$D(J(L+1))
- I DB S DB=DB(F),DIART=DIART(F),DIAO=DIAO(F),DIAT=$S(DIAO<0:"",DIAO:^DIE(DIAA,"DR",DIART,J(L),DIAO),$D(^DIE(DIAA,"DR",DIART,J(L))):^(J(L)),1:"")
- S DIAR=DIAR(F),DIAP=DIAP(F),DI=J(L),F=F-1 G 2
- ;
- EN ;
- D DICS
- DOWN S F=F+1,DIAP(F)=DIAP,DIAP=0,DIAR(F)=DIAR F %=F+1:.01 I '$D(DR(%,DI)) S:%["." DR(DIAR,X)=DR(DIAR,X)_U_%_";",DIAP(F)=DIAP(F)+1 S DIAR=% Q
- G GO:'DB!$D(DIEFMT) S DIART(F)=DIART,DIART=F+1,%=$P(DIAT,";",DB) I %?1"^".NP S DIART=$P(%,U,2),DB=DB+1
- S DB(F)=DB,DB=1,DIAO(F)=DIAO,DIAO=0,DIAT=$G(^DIE(DIAA,"DR",DIART,DI))
- GO G 1:$D(DIAM),1:$O(^DD(DI,.01))>0,1:L#100=0,UP
- DICS ;
- S DIC("S")="I Y>.001,$P(^(0),U,2)'[""C"" Q:$G(^(9))="""" I ^(9)'=U" I DUZ(0)'="@" S DIC("S")="I $P(^(0),U,2)'[""Q"" "_DIC("S")_",$TR(DUZ(0),^(9))'=DUZ(0)"
- Q
- ;
- P ;
- S DRS=99,Y=X D DB G 2
- ;
- SET S Y=+Y_DV
- DB ;
- I DB,'DSC S DB=DB+1
- D ;
- I '$D(DR(DIAR,DI)) S DR(DIAR,DI)="",DIAP=0
- E I $L(DR(DIAR,DI))+$L(Y)>230 F %=0:1 I '$D(^UTILITY($J,"OV",DIAR,DI,%)) S DIAP=DIAP\1000+1*1000,^(%)=DR(DIAR,DI),DR(DIAR,DI)="" Q
- S DR(DIAR,DI)=DR(DIAR,DI)_Y_";",DRS=DRS+1,DIAP=DIAP+1 I $D(DIAB),Y'="Q" S ^UTILITY($J,DIAP#1000,DIAR-1,DI,DIAP\1000)=DIAB
- INHDIA(%T,%F) ;GFT,JSH; 16 Nov 95 16:22;Generic Interface - create an Input Template
- +1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
- +2 ;COPYRIGHT 1991-2000 SAIC
- +3 ;
- +4 ;%T = name of template
- +5 ;%F = file number^global reference
- +6 ;Enter with ^UTILITY("INDIA",$J,n) [n=1,2,3...] containing the lines for the template
- +7 ;
- +8 SET DIC=U_$PIECE(%F,U,2)
- NEW T
- IF '$DATA(DMAX)
- SET DMAX=$GET(^DD("ROU"))
- IF 'DMAX
- SET DMAX=4000
- +9 SET DIA=DIC
- SET DI=+%F
- SET (J(0),DIA("P"))=DI
- SET DIA("DIET")=$GET(^DIC(DI,0,"DIET"))
- +10 DO QQ
- SET DR=""
- SET (DIEFMT,L,DIAR,DRS,DIAP,DB,DSC)=0
- SET F=-1
- SET I(0)=DIA
- SET DXS=1
- DO EN
- +11 IF '$ORDER(^UTILITY("INDIA",$JOB,0))
- QUIT
- +12 SET INI=0
- FOR
- SET INI=$ORDER(^UTILITY("INDIA",$JOB,INI))
- IF 'INI
- QUIT
- SET X=^(INI)
- IF '(INI#5)
- WRITE "."
- DO L
- +13 FOR
- IF 'F
- QUIT
- DO UP
- STORE ;Store the template
- +1 FOR F=0:0
- SET F=$ORDER(^UTILITY($JOB,"OV",F))
- IF 'F
- QUIT
- FOR X=0:0
- SET X=$ORDER(^UTILITY($JOB,"OV",F,X))
- IF 'X
- QUIT
- SET DW=DR(F,X)
- SET DR(F,X)=^(X,0)
- SET I=1
- DO OV
- +2 GOTO S
- +3 ;
- OV IF '$DATA(^(I))
- SET DR(F,X,I)=DW
- QUIT
- +1 SET DR(F,X,I)=^(I)
- SET I=I+1
- GOTO OV
- +2 ;
- S SET DIC="^DIE("
- SET DIC(0)="LZ"
- SET DIC("S")="I $P(^(0),U,4)="_+%F
- SET D="F"_+%F
- SET X=%T
- DO IX^DIC
- KILL DIC
- SET %=$PIECE(Y,U,3)
- +1 LOCK +^DIE
- KILL ^DIE(+Y)
- SET ^(+Y,0)=X_U_DT_U_"@"_U_+%F_U_U_"@"
- SET ^DIE("F"_+%F,X,+Y)=1
- LOCK -^DIE
- KILL ^UTILITY($JOB,"OV")
- +2 MERGE ^DIE(+Y,"DR")=DR,^DIE(+Y,"DIAB")=^UTILITY($JOB)
- +3 SET X=%T
- DO EN^DIEZ
- +4 ;
- Q KILL DI,DLAYGO,DIA,I,J
- QQ KILL ^UTILITY($JOB),DICHK,DIAT,DIART,DIAR,DIAB,DIAO,DIAP,DIAA,IOP,DSC,DIA3,DHIT,DRS,DIE,DR,DA,DG,DIC,F,DP,DQ,DV,DB,DW,D,X,Y,L
- QUIT
- 1 QUIT
- L KILL DIC,DIAB,DIAM
- SET DSC=X?1"^".E
- IF DSC
- SET X=$EXTRACT(X,2,999)
- IF U[X
- KILL DR
- QUIT
- +1 IF $ASCII(X)=64
- IF X'?1P.N
- GOTO AT^INHDIA3
- IF $LENGTH(X)>1
- GOTO P
- IF 'DB
- GOTO X
- SET DB=DB+1
- GOTO 2
- +2 DO DICS
- SET DV=""
- SET J=$PIECE(X,"-",2)
- DIC ;
- +1 KILL Y
- SET DIC(0)="Z"
- SET DIC="^DD(DI,"
- DO ^DIC
- +2 IF Y>0
- DO SET
- SET Y=$PIECE(Y(0),U,2)
- IF 'Y
- GOTO 2
- SET X=DI
- SET L=L+1
- SET (DI,J(L))=+Y
- SET I(L)=""""_$PIECE($PIECE(Y(0),U,4),";")_""""
- GOTO DOWN
- +3 FOR D=124,93
- IF $ASCII(X)=D
- IF D=124
- SET DIAB=X
- SET DIAM=1
- SET DRS=9
- SET X=$EXTRACT(X,2,999)
- IF X]""
- GOTO DIC
- GOTO UP
- +4 SET DIC(0)="Y"
- SET D="GR"
- IF $DATA(^DD(DI,D))
- DO IX^DIC
- IF Y>0
- DO SET
- GOTO 2
- +5 GOTO X^INHDIA3
- +6 ;
- F SET X=$PIECE(^DD(DI,0),U)
- IF F
- IF X="FIELD"
- SET X=$ORDER(^(0,"NM",0))_" "_X
- +1 QUIT
- +2 ;
- X ;
- +1 WRITE !,*7,"Field: '"_$PIECE(^UTILITY("INDIA",$JOB,INI),"///")_"' is invalid in template. (It may be COMPUTED)"
- KILL Y
- DO DICS
- 2 ;
- +1 QUIT
- UP ;
- +1 IF 'F
- QUIT
- +2 KILL I(L),J(L)
- SET L=L-1
- IF '$DATA(J(L))
- FOR L=L-99:1
- IF '$DATA(J(L+1))
- QUIT
- +3 IF DB
- SET DB=DB(F)
- SET DIART=DIART(F)
- SET DIAO=DIAO(F)
- SET DIAT=$SELECT(DIAO<0:"",DIAO:^DIE(DIAA,"DR",DIART,J(L),DIAO),$DATA(^DIE(DIAA,"DR",DIART,J(L))):^(J(L)),1:"")
- +4 SET DIAR=DIAR(F)
- SET DIAP=DIAP(F)
- SET DI=J(L)
- SET F=F-1
- GOTO 2
- +5 ;
- EN ;
- +1 DO DICS
- DOWN SET F=F+1
- SET DIAP(F)=DIAP
- SET DIAP=0
- SET DIAR(F)=DIAR
- FOR %=F+1:.01
- IF '$DATA(DR(%,DI))
- IF %["."
- SET DR(DIAR,X)=DR(DIAR,X)_U_%_";"
- SET DIAP(F)=DIAP(F)+1
- SET DIAR=%
- QUIT
- +1 IF 'DB!$DATA(DIEFMT)
- GOTO GO
- SET DIART(F)=DIART
- SET DIART=F+1
- SET %=$PIECE(DIAT,";",DB)
- IF %?1"^".NP
- SET DIART=$PIECE(%,U,2)
- SET DB=DB+1
- +2 SET DB(F)=DB
- SET DB=1
- SET DIAO(F)=DIAO
- SET DIAO=0
- SET DIAT=$GET(^DIE(DIAA,"DR",DIART,DI))
- GO IF $DATA(DIAM)
- GOTO 1
- IF $ORDER(^DD(DI,.01))>0
- GOTO 1
- IF L#100=0
- GOTO 1
- GOTO UP
- DICS ;
- +1 SET DIC("S")="I Y>.001,$P(^(0),U,2)'[""C"" Q:$G(^(9))="""" I ^(9)'=U"
- IF DUZ(0)'="@"
- SET DIC("S")="I $P(^(0),U,2)'[""Q"" "_DIC("S")_",$TR(DUZ(0),^(9))'=DUZ(0)"
- +2 QUIT
- +3 ;
- P ;
- +1 SET DRS=99
- SET Y=X
- DO DB
- GOTO 2
- +2 ;
- SET SET Y=+Y_DV
- DB ;
- +1 IF DB
- IF 'DSC
- SET DB=DB+1
- D ;
- +1 IF '$DATA(DR(DIAR,DI))
- SET DR(DIAR,DI)=""
- SET DIAP=0
- +2 IF '$TEST
- IF $LENGTH(DR(DIAR,DI))+$LENGTH(Y)>230
- FOR %=0:1
- IF '$DATA(^UTILITY($JOB,"OV",DIAR,DI,%))
- SET DIAP=DIAP\1000+1*1000
- SET ^(%)=DR(DIAR,DI)
- SET DR(DIAR,DI)=""
- QUIT
- +3 SET DR(DIAR,DI)=DR(DIAR,DI)_Y_";"
- SET DRS=DRS+1
- SET DIAP=DIAP+1
- IF $DATA(DIAB)
- IF Y'="Q"
- SET ^UTILITY($JOB,DIAP#1000,DIAR-1,DI,DIAP\1000)=DIAB
