- DICATT1 ;SFISC/GFT,XAK-NODE AND PIECE, SUBFILE ;2/16/93 17:14
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- I DA=.001 S W=" " G 2
- S (DG,W)=$P(O,U,4) G M:W="" S T=0,DP=DA,Y=$P(W,";",1),N=$P(W,";",2) D MX S L=L-T D MAX I T<252 S W=DG G ^DICATT2
- D TOO G NO^DICATT2
- M K DE,DG W !,"WILL "_F_" FIELD BE MULTIPLE" S %=2 D YN^DICN I % S V=%=1 G BACK:%<0,SUB
- W !,"FOR A GIVEN ENTRY, WILL THERE BE MORE THAN 1 "_F,!," ON FILE AT ONCE?" G M
- E ;
- S V=0,DE(3)=$S($D(^(3)):^(3),1:""),T=0,DP=E,N=$P($P(DE,U,4),";",2) D MX S L=T
- SUB S:$P(DIZ,"^")["K" V=1 S T=0 F Y=0:1 Q:'$D(^DD(A,"GL",Y+1))
- D MAX:'V I T>245!$D(^DD(A,"GL",Y,0))!V S Y=$S(+Y=Y:Y+1,1:$C($A(Y)+1))
- G SB:DUZ(0)'="@"
- W !!,"SUBSCRIPT: ",Y,"// " R X:DTIME S:'$T X=U,DTOUT=1 S:X="" X=Y
- I X'?.ANP W !?5,$C(7),"Control Characters are not allowed." G SUB
- I +X'=X G BACK:X[U,DICATT1^DIQQQ:X["?" I X?1P.E!(X[",")!(X[":")!(X[S)!(X[Q)!(X["=") G SUB
- I Y'=X S Y=X D MAX I T>250 D TOO G SUB
- SB S W=Y,X=0 G V:V,U:$D(^DD(A,"GL",W,0))
- PIECE S Y=1,P=0
- PC S X=$O(^DD(A,"GL",W,X)) I X'="" S P=$P(X,",",2),Y=$S(Y>P:Y,1:P+1) G PC
- S X=-1 I P S Y="E"_Y_","_(L+Y-1)
- E F Y=1:1 Q:'$D(^(Y))
- S P=Y I DUZ(0)="@" W !,"^-PIECE POSITION: ",Y,"// " R P:DTIME S:'$T DTOUT=1 G CHECK^DICATT:$D(DTOUT) S:P="" P=Y
- G PQ:P["?" I P?1"E"1N.N1","1N.N S N=$P(P,",",2)-$E(P,2,9)+1 G USED:N'<L W $C(7),!,"CAN'T BE <",L G PIECE
- I P>0,P<100,P\1=P G USED
- S W="" I X'[U W $C(7),"??" G SUB
- BACK G CHECK^DICATT:$D(DTOUT),TYPE^DICATT2
- ;
- PQ W " TYPE A NUMBER FROM 1 TO 99"
- I Y=1 W !?9,"OR AN $EXTRACT RANGE (E.G., ""E2,4"")"
- E W !?15,"CURRENTLY ASSIGNED:",! S Y="" F P=0:0 S Y=$O(^DD(A,"GL",W,Y)) Q:Y="" S P=$O(^(Y,0)) I $D(^DD(A,P,0)) W ?11,$S(Y:"PIECE ",1:"")_Y,?22,"FIELD #"_P_", '"_$P(^(0),U,1)_"'",!
- G PIECE
- ;
- USED S W=W_S_P,X=P G DE:'$D(^(X))
- U W !,$C(7),X_" ALREADY USED FOR "_$P(^DD(A,$O(^(X,0)),0),U,1) G SUB
- ;
- MAX S N=0 F T=L:0 S N=$O(^DD(A,"GL",Y,N)) Q:N="" S DP=$O(^(N,0)) D MX
- S N=-1 Q
- MX I N?1"E".E S T=T+$P(N,",",2)-$E(N,2,9)+1
- Q:'N S P=$P(^DD(A,DP,0),U,2),W=$S(P["J":$P(P,"J",2),P["P":9,P["N":14,P["D":7,1:0) G W:W
- I P["S" F P=1:1 S X=$L($P($P($P(^(0),U,3),";",P),":",1)) S:X>W W=X G W:'X
- S W=$P(^(0),"$L(X)>",2),W='W*30+W
- W S T=T+W+1 Q
- ;
- V I $D(^DD(A,"GL",W)) W $C(7),!?9,"CAN'T STORE A "_$S($P(DIZ,U)["K":"MUMPS",1:"MULTIPLE")_" FIELD IN AN ALREADY-USED SUBSCRIPT!" G SUB
- I $P(Z,U)'["K" S W=W_S_0 S:$P(DIZ,U)["K" W=$P(W,";")_";E1,245"
- DE I $D(DE) S ^DD(A,DA,0)=F_U_$P(DE,U,2,3)_U_W_U_$P(DE,U,5,99),DIK="^DD(A,",DA(1)=A,^(3)=DE(3),^("DT")=DT D IX1^DIK G N^DICATT
- 2 S:$P(Z,U)["K" V=0,W=W_";E1,245",M="This is Standard MUMPS code." G ^DICATT2
- ;
- TOO W $C(7),!," TOO MUCH TO STORE AT THAT SUBSCRIPT!"
- DICATT1 ;SFISC/GFT,XAK-NODE AND PIECE, SUBFILE ;2/16/93 17:14
- +1 ;;22.0;VA FileMan;;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 IF DA=.001
- SET W=" "
- GOTO 2
- +4 SET (DG,W)=$PIECE(O,U,4)
- IF W=""
- GOTO M
- SET T=0
- SET DP=DA
- SET Y=$PIECE(W,";",1)
- SET N=$PIECE(W,";",2)
- DO MX
- SET L=L-T
- DO MAX
- IF T<252
- SET W=DG
- GOTO ^DICATT2
- +5 DO TOO
- GOTO NO^DICATT2
- M KILL DE,DG
- WRITE !,"WILL "_F_" FIELD BE MULTIPLE"
- SET %=2
- DO YN^DICN
- IF %
- SET V=%=1
- IF %<0
- GOTO BACK
- GOTO SUB
- +1 WRITE !,"FOR A GIVEN ENTRY, WILL THERE BE MORE THAN 1 "_F,!," ON FILE AT ONCE?"
- GOTO M
- E ;
- +1 SET V=0
- SET DE(3)=$SELECT($DATA(^(3)):^(3),1:"")
- SET T=0
- SET DP=E
- SET N=$PIECE">PIECE($PIECE">PIECE(DE,U,4),";",2)
- DO MX
- SET L=T
- SUB IF $PIECE(DIZ,"^")["K"
- SET V=1
- SET T=0
- FOR Y=0:1
- IF '$DATA(^DD(A,"GL",Y+1))
- QUIT
- +1 IF 'V
- DO MAX
- IF T>245!$DATA(^DD(A,"GL",Y,0))!V
- SET Y=$SELECT(+Y=Y:Y+1,1:$CHAR($ASCII(Y)+1))
- +2 IF DUZ(0)'="@"
- GOTO SB
- +3 WRITE !!,"SUBSCRIPT: ",Y,"// "
- READ X:DTIME
- IF '$TEST
- SET X=U
- SET DTOUT=1
- IF X=""
- SET X=Y
- +4 IF X'?.ANP
- WRITE !?5,$CHAR(7),"Control Characters are not allowed."
- GOTO SUB
- +5 IF +X'=X
- IF X[U
- GOTO BACK
- IF X["?"
- GOTO DICATT1^DIQQQ
- IF X?1P.E!(X[",")!(X[":")!(X[S)!(X[Q)!(X["=")
- GOTO SUB
- +6 IF Y'=X
- SET Y=X
- DO MAX
- IF T>250
- DO TOO
- GOTO SUB
- SB SET W=Y
- SET X=0
- IF V
- GOTO V
- IF $DATA(^DD(A,"GL",W,0))
- GOTO U
- PIECE SET Y=1
- SET P=0
- PC SET X=$ORDER(^DD(A,"GL",W,X))
- IF X'=""
- SET P=$PIECE(X,",",2)
- SET Y=$SELECT(Y>P:Y,1:P+1)
- GOTO PC
- +1 SET X=-1
- IF P
- SET Y="E"_Y_","_(L+Y-1)
- +2 IF '$TEST
- FOR Y=1:1
- IF '$DATA(^(Y))
- QUIT
- +3 SET P=Y
- IF DUZ(0)="@"
- WRITE !,"^-PIECE POSITION: ",Y,"// "
- READ P:DTIME
- IF '$TEST
- SET DTOUT=1
- IF $DATA(DTOUT)
- GOTO CHECK^DICATT
- IF P=""
- SET P=Y
- +4 IF P["?"
- GOTO PQ
- IF P?1"E"1N.N1","1N.N
- SET N=$PIECE(P,",",2)-$EXTRACT(P,2,9)+1
- IF N'<L
- GOTO USED
- WRITE $CHAR(7),!,"CAN'T BE <",L
- GOTO PIECE
- +5 IF P>0
- IF P<100
- IF P\1=P
- GOTO USED
- +6 SET W=""
- IF X'[U
- WRITE $CHAR(7),"??"
- GOTO SUB
- BACK IF $DATA(DTOUT)
- GOTO CHECK^DICATT
- GOTO TYPE^DICATT2
- +1 ;
- PQ WRITE " TYPE A NUMBER FROM 1 TO 99"
- +1 IF Y=1
- WRITE !?9,"OR AN $EXTRACT RANGE (E.G., ""E2,4"")"
- +2 IF '$TEST
- WRITE !?15,"CURRENTLY ASSIGNED:",!
- SET Y=""
- FOR P=0:0
- SET Y=$ORDER(^DD(A,"GL",W,Y))
- IF Y=""
- QUIT
- SET P=$ORDER(^(Y,0))
- IF $DATA(^DD(A,P,0))
- WRITE ?11,$SELECT(Y:"PIECE ",1:"")_Y,?22,"FIELD #"_P_", '"_$PIECE(^(0),U,1)_"'",!
- +3 GOTO PIECE
- +4 ;
- USED SET W=W_S_P
- SET X=P
- IF '$DATA(^(X))
- GOTO DE
- U WRITE !,$CHAR(7),X_" ALREADY USED FOR "_$PIECE(^DD(A,$ORDER(^(X,0)),0),U,1)
- GOTO SUB
- +1 ;
- MAX SET N=0
- FOR T=L:0
- SET N=$ORDER(^DD(A,"GL",Y,N))
- IF N=""
- QUIT
- SET DP=$ORDER(^(N,0))
- DO MX
- +1 SET N=-1
- QUIT
- MX IF N?1"E".E
- SET T=T+$PIECE(N,",",2)-$EXTRACT(N,2,9)+1
- +1 IF 'N
- QUIT
- SET P=$PIECE(^DD(A,DP,0),U,2)
- SET W=$SELECT(P["J":$PIECE(P,"J",2),P["P":9,P["N":14,P["D":7,1:0)
- IF W
- GOTO W
- +2 IF P["S"
- FOR P=1:1
- SET X=$LENGTH($PIECE">PIECE">PIECE">PIECE($PIECE">PIECE">PIECE">PIECE($PIECE">PIECE">PIECE">PIECE(^(0),U,3),";",P),":",1))
- IF X>W
- SET W=X
- IF 'X
- GOTO W
- +3 SET W=$PIECE(^(0),"$L(X)>",2)
- SET W='W*30+W
- W SET T=T+W+1
- QUIT
- +1 ;
- V IF $DATA(^DD(A,"GL",W))
- WRITE $CHAR(7),!?9,"CAN'T STORE A "_$SELECT($PIECE(DIZ,U)["K":"MUMPS",1:"MULTIPLE")_" FIELD IN AN ALREADY-USED SUBSCRIPT!"
- GOTO SUB
- +1 IF $PIECE(Z,U)'["K"
- SET W=W_S_0
- IF $PIECE(DIZ,U)["K"
- SET W=$PIECE(W,";")_";E1,245"
- DE IF $DATA(DE)
- SET ^DD(A,DA,0)=F_U_$PIECE">PIECE(DE,U,2,3)_U_W_U_$PIECE">PIECE(DE,U,5,99)
- SET DIK="^DD(A,"
- SET DA(1)=A
- SET ^(3)=DE(3)
- SET ^("DT")=DT
- DO IX1^DIK
- GOTO N^DICATT
- 2 IF $PIECE(Z,U)["K"
- SET V=0
- SET W=W_";E1,245"
- SET M="This is Standard MUMPS code."
- GOTO ^DICATT2
- +1 ;
- TOO WRITE $CHAR(7),!," TOO MUCH TO STORE AT THAT SUBSCRIPT!"
