DICATT1 ;SFISC/GFT - XAK-NODE AND PIECE, SUBFILE ;8APR2016
;;22.2;VA FileMan;**2,20**;Jan 05, 2016;Build 2
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;;GFT;**1032,1055,1062**
;
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,";"),N=$P(W,";",2) D MX S L=L-T D MAX I T+3<$G(^DD("STRING_LIMIT"),255) 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 ;FROM DICATT2 WHEN <SPACEBAR> DUPLICATES A FIELD
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 ;Ask which SUBSCRIPT -- FROM ABOVE, AND FROM 9+1^DICATT ('MUMPS') TYPE, DIZ contains pieces 2 & 3 of ^DD zero node, use $P(DIZ,U) ;p20
S:$P(DIZ,U)["K" V=1 S T=0 F Y=0:1 Q:'$D(^DD(A,"GL",Y+1))
D MAX:'V I $D(^DD(A,"GL",Y,0))!V!(T>245)!($$ESTORE($P(DIZ,U))&$O(^(""))) S Y=$S(+Y=Y:Y+1,1:$C($A(Y)+1)) ;GET THE NEXT UNUSED SUBSCRIPT
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<0 W !?5,$C(7),"Negative subscripts 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+5>$G(^DD("STRING_LIMIT"),255) D TOO G SUB
SB S W=Y,X=0 G V:V,U:$D(^DD(A,"GL",W,0)),SUB:$$ESTORE($P(DIZ,U))&$O(^(""))
PIECE S Y=1,P=0,V=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) S:P V=1 G PC
I V!$$ESTORE($P(DIZ,U)) S Y="E"_Y_","_(L+Y-1)
E F Y=1:1 Q:'$D(^DD(A,"GL",W,Y))
S X=-1,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 PIECE:$O(^DD(A,"GL",W,0)),USED:N'<L W $C(7),!,"CAN'T BE <",L G PIECE
I P>0,P<100,P\1=P G PIECE:Y?1"E".E,USED ;DON'T ENTER A PIECE NUMBER, IF OTHER DATA IS STORED BY EXTRACT!
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 ;GO THRU ALL THE FIELDS STORED ON SUBSCRIPT 'Y'
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 ;return the Total characters stored for field 'DP'
;
;
;
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!"
Q
;
ESTORE(DIZ) ;also called from DICATTDM for screen mode
I +$P(DIZ,"t",2)=12!(DIZ["K") Q 1 ;TYPES 'LABEL REFERENCE' AND 'MUMPS' MUST BE STORED BY E
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICATT1 3816 printed Jan 18, 2025@03:46:28 Page 2
DICATT1 ;SFISC/GFT - XAK-NODE AND PIECE, SUBFILE ;8APR2016
+1 ;;22.2;VA FileMan;**2,20**;Jan 05, 2016;Build 2
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;;GFT;**1032,1055,1062**
+7 ;
+8 IF DA=.001
SET W=" "
GOTO 2
+9 SET (DG,W)=$PIECE(O,U,4)
if W=""
GOTO M
SET T=0
SET DP=DA
SET Y=$PIECE(W,";")
SET N=$PIECE(W,";",2)
DO MX
SET L=L-T
DO MAX
IF T+3<$GET(^DD("STRING_LIMIT"),255)
SET W=DG
GOTO ^DICATT2
+10 DO TOO
GOTO NO^DICATT2
+11 ;
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
+2 ;
E ;FROM DICATT2 WHEN <SPACEBAR> DUPLICATES A FIELD
+1 SET V=0
SET DE(3)=$SELECT($DATA(^(3)):^(3),1:"")
SET T=0
SET DP=E
SET N=$PIECE($PIECE(DE,U,4),";",2)
DO MX
SET L=T
+2 ;
SUB ;Ask which SUBSCRIPT -- FROM ABOVE, AND FROM 9+1^DICATT ('MUMPS') TYPE, DIZ contains pieces 2 & 3 of ^DD zero node, use $P(DIZ,U) ;p20
+1 if $PIECE(DIZ,U)["K"
SET V=1
SET T=0
FOR Y=0:1
if '$DATA(^DD(A,"GL",Y+1))
QUIT
+2 ;GET THE NEXT UNUSED SUBSCRIPT
if 'V
DO MAX
IF $DATA(^DD(A,"GL",Y,0))!V!(T>245)!($$ESTORE($PIECE(DIZ,U))&$ORDER(^("")))
SET Y=$SELECT(+Y=Y:Y+1,1:$CHAR($ASCII(Y)+1))
+3 if DUZ(0)'="@"
GOTO SB
+4 WRITE !!,"SUBSCRIPT: ",Y,"// "
READ X:DTIME
if '$TEST
SET X=U
SET DTOUT=1
if X=""
SET X=Y
+5 IF X'?.ANP
WRITE !?5,$CHAR(7),"Control Characters are not allowed."
GOTO SUB
+6 IF X<0
WRITE !?5,$CHAR(7),"Negative subscripts are not allowed."
GOTO SUB
+7 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
+8 IF Y'=X
SET Y=X
DO MAX
IF T+5>$GET(^DD("STRING_LIMIT"),255)
DO TOO
GOTO SUB
SB SET W=Y
SET X=0
if V
GOTO V
if $DATA(^DD(A,"GL",W,0))
GOTO U
if $$ESTORE($PIECE(DIZ,U))&$ORDER(^(""))
GOTO SUB
PIECE SET Y=1
SET P=0
SET V=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)
if P
SET V=1
GOTO PC
+1 IF V!$$ESTORE($PIECE(DIZ,U))
SET Y="E"_Y_","_(L+Y-1)
+2 IF '$TEST
FOR Y=1:1
if '$DATA(^DD(A,"GL",W,Y))
QUIT
+3 SET X=-1
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 $ORDER(^DD(A,"GL",W,0))
GOTO PIECE
if N'<L
GOTO USED
WRITE $CHAR(7),!,"CAN'T BE <",L
GOTO PIECE
+5 ;DON'T ENTER A PIECE NUMBER, IF OTHER DATA IS STORED BY EXTRACT!
IF P>0
IF P<100
IF P\1=P
if Y?1"E".E
GOTO PIECE
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 ;GO THRU ALL THE FIELDS STORED ON SUBSCRIPT 'Y'
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
+2 ;
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(^(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 ;return the Total characters stored for field 'DP'
SET T=T+W+1
QUIT
+1 ;
+2 ;
+3 ;
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(DE,U,2,3)_U_W_U_$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!"
+1 QUIT
+2 ;
ESTORE(DIZ) ;also called from DICATTDM for screen mode
+1 ;TYPES 'LABEL REFERENCE' AND 'MUMPS' MUST BE STORED BY E
IF +$PIECE(DIZ,"t",2)=12!(DIZ["K")
QUIT 1
+2 QUIT 0
