ENCTFLD ;(WASH ISC)/RGY-Enter/edit File 446.5 ;1-11-90
;;7.0;ENGINEERING;;Aug 17, 1993
;Copy of PRCTFLD ;DH-WASH ISC
S ENCTF=+$P(^PRCT(446.5,DA(1),0),"^",2),ENCTFLDS="",ENCTEXT=0 S ENCTDEF=$P(^(2,DA,0),"^",4) I 'ENCTF W *7 D NOFIL^ENCTMES2 G Q
I ENCTDEF]"" W !!,"The following field translates as the" S ENCTE=ENCTDEF,FL=ENCTF F Y=0:0 S Y=+ENCTE,ENCTE=$P(ENCTE,+ENCTE,2,999) Q:Y=0 D DIS S ENCTE=$E(ENCTE,2,999)
A S X=" "_$S($D(^DIC(ENCTF,0,"GL")):$P(@(^("GL")_"0)"),"^"),1:$P(^DD(ENCTF,0),"^"))_" FIELD:"_$S(ENCTDEF]"":" "_ENCTDEF_"//",1:"")_"^^^^^^1" D ^ENCTQUES G:X="^" Q
S DIC("W")="I $P(^(0),U,2) W $P("" (multiple)^ (word-processing)"",U,$P(^DD(+$P(^(0),U,2),.01,0),U,2)[""W""+1)"
S:$L(X,":")-1 ENCTEXT=1,X=$P(X,":",1,$L(X,":")-1) S DIC="^DD("_ENCTF_",",DIC(0)="QEM" D ^DIC G A:X["?",Q:X=""&(Y<0) G:Y<0 A S X=+Y
I ENCTEXT S ENCTEXT=0,Y=+$P($P(^DD(ENCTF,X,0),"^",2),"P",2) W:'Y *7," ... Field not a pointer !" S:Y ENCTF=Y,ENCTDEF="",ENCTFLDS=ENCTFLDS_X_":" G A
I $P(^DD(ENCTF,+X,0),"^",2) S ENCTFLDS=ENCTFLDS_X_",",ENCTF=+$P(^DD(ENCTF,+X,0),"^",2),ENCTDEF="" G A
S $P(^PRCT(446.5,DA(1),2,DA,0),"^",4)=ENCTFLDS_X
Q K FL,ENCTDEF,ENCTFLDS,ENCTF,ENCTEXT,DIC Q
DIS ;
W !,$S($D(^DD(FL,Y,0)):$P(^(0),"^"),1:"*** UNKNOWN ***")," field of the ",$S($D(^DIC(FL,0)):$P(^(0),"^")_" file",$D(^DD(FL,0)):$P(^(0),"^")_" multiple",1:"*** UNKNOWN ***")
I $E(ENCTE)]"" W " which extends to the" S FL=$S($D(^DD(FL,Y,0)):$S($E(ENCTE)=":":+$P($P(^(0),"^",2),"P",2),1:+$P(^(0),"^",2)),1:-1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HENCTFLD 1506 printed Dec 13, 2024@01:52:09 Page 2
ENCTFLD ;(WASH ISC)/RGY-Enter/edit File 446.5 ;1-11-90
+1 ;;7.0;ENGINEERING;;Aug 17, 1993
+2 ;Copy of PRCTFLD ;DH-WASH ISC
+3 SET ENCTF=+$PIECE(^PRCT(446.5,DA(1),0),"^",2)
SET ENCTFLDS=""
SET ENCTEXT=0
SET ENCTDEF=$PIECE(^(2,DA,0),"^",4)
IF 'ENCTF
WRITE *7
DO NOFIL^ENCTMES2
GOTO Q
+4 IF ENCTDEF]""
WRITE !!,"The following field translates as the"
SET ENCTE=ENCTDEF
SET FL=ENCTF
FOR Y=0:0
SET Y=+ENCTE
SET ENCTE=$PIECE(ENCTE,+ENCTE,2,999)
if Y=0
QUIT
DO DIS
SET ENCTE=$EXTRACT(ENCTE,2,999)
A SET X=" "_$SELECT($DATA(^DIC(ENCTF,0,"GL")):$PIECE(@(^("GL")_"0)"),"^"),1:$PIECE(^DD(ENCTF,0),"^"))_" FIELD:"_$SELECT(ENCTDEF]"":" "_ENCTDEF_"//",1:"")_"^^^^^^1"
DO ^ENCTQUES
if X="^"
GOTO Q
+1 SET DIC("W")="I $P(^(0),U,2) W $P("" (multiple)^ (word-processing)"",U,$P(^DD(+$P(^(0),U,2),.01,0),U,2)[""W""+1)"
+2 if $LENGTH(X,"
SET ENCTEXT=1
SET X=$PIECE(X,":",1,$LENGTH(X,":")-1)
SET DIC="^DD("_ENCTF_","
SET DIC(0)="QEM"
DO ^DIC
if X["?"
GOTO A
if X=""&(Y<0)
GOTO Q
if Y<0
GOTO A
SET X=+Y
+3 IF ENCTEXT
SET ENCTEXT=0
SET Y=+$PIECE($PIECE(^DD(ENCTF,X,0),"^",2),"P",2)
if 'Y
WRITE *7," ... Field not a pointer !"
if Y
SET ENCTF=Y
SET ENCTDEF=""
SET ENCTFLDS=ENCTFLDS_X_":"
GOTO A
+4 IF $PIECE(^DD(ENCTF,+X,0),"^",2)
SET ENCTFLDS=ENCTFLDS_X_","
SET ENCTF=+$PIECE(^DD(ENCTF,+X,0),"^",2)
SET ENCTDEF=""
GOTO A
+5 SET $PIECE(^PRCT(446.5,DA(1),2,DA,0),"^",4)=ENCTFLDS_X
Q KILL FL,ENCTDEF,ENCTFLDS,ENCTF,ENCTEXT,DIC
QUIT
DIS ;
+1 WRITE !,$SELECT($DATA(^DD(FL,Y,0)):$PIECE(^(0),"^"),1:"*** UNKNOWN ***")," field of the ",$SELECT($DATA(^DIC(FL,0)):$PIECE(^(0),"^")_" file",$DATA(^DD(FL,0)):$PIECE(^(0),"^")_" multiple",1:"*** UNKNOWN ***")
+2 IF $EXTRACT(ENCTE)]""
WRITE " which extends to the"
SET FL=$SELECT($DATA(^DD(FL,Y,0)):$SELECT($EXTRACT(ENCTE)=":":+$PIECE($PIECE(^(0),"^",2),"P",2),1:+$PIECE(^(0),"^",2)),1:-1)
+3 QUIT
