GMRGUT3 ;CISC/RM-UTILITIES ROUTINE FOR GMRG FILES (CONT.) ;5/28/92
;;3.0;Text Generator;;Jan 24, 1996
EN1 ; ENTRY FROM IDENTIFIER NODE FOR PARENT
S:$D(DX)#2 GMR("DX")=DX S:$D(DY)#2 GMR("DY")=DY S GMR("SPC")=5,GMR("LEVEL")=0,GMR("%")=$S($D(IOSL):IOSL-5,1:19),GMR("OUT")=0 D RECUR1
I GMR("OUT") S DX=$S($X'>80:$X,1:80),DY=$S('$D(DZ):0,DZ'?1"?".E:0,1:GMR("%")+5) X ^%ZOSF("XY")
S:$D(GMR("DX")) DX=GMR("DX") S:$D(GMR("DY")) DY=GMR("DY") K GMR W @("$E("_DIC_"Y,0),0)")
Q
RECUR1 ;
S GMR("DATA")=$S($D(^GMRD(124.2,+Y,0)):^(0),1:"") W !?GMR("SPC")," ",$S($P(GMR("DATA"),U,2)="":"",$P(GMR("DATA"),U,2)=2:"FRAME",1:"TERM")
W ?(GMR("SPC")+8)," ",$P(GMR("DATA"),U,3)
W ?(GMR("SPC")+16)," ",$S($D(^GMRD(124.25,+$P(GMR("DATA"),U,4),0)):$P(^(0),"^"),1:"")
D:$Y>GMR("%") EOP Q:GMR("OUT")
D E2 Q:GMR("OUT") S GMR("SPC")=GMR("SPC")-11
Q
EOP ;
S DX=$S($X'>80:$X,1:80),DY=0,$P(GMR("%"),"^",2)=1 X ^%ZOSF("XY") W !?3,"Type an '^' to stop the parent list for this term: " R GMR("^"):DTIME I GMR("^")="^"!(GMR("^")="^^")!'$T S GMR("OUT")=1 Q
Q
E2 ;
F GMR(GMR("LEVEL"))=0:0 S GMR(GMR("LEVEL"))=$O(^GMRD(124.2,"AKID",+Y,GMR(GMR("LEVEL")))) Q:GMR(GMR("LEVEL"))'>0!GMR("OUT") I $D(^(GMR(GMR("LEVEL")),0)) D CWR Q:GMR("OUT")
Q
CWR ;
S GMR("L")=$O(^GMRD(124.2,GMR(GMR("LEVEL")),1,"B",+Y,0)) D:$S(GMR("L")'>0:0,'$D(^GMRD(124.2,GMR(GMR("LEVEL")),1,GMR("L"),0)):0,'$P(^(0),"^",6):1,1:0) WRTID
Q
WRTID ;
W ! W:'$D(GMR("FL",GMR("LEVEL"))) ?(GMR("SPC")+3),"PARENT: " W:$D(^GMRD(124.2,GMR(GMR("LEVEL")),0)) ?(GMR("SPC")+11),$P(^GMRD(124.2,GMR(GMR("LEVEL")),0),U) S GMR("FL",GMR("LEVEL"))=1
D:$Y>GMR("%") EOP Q:GMR("OUT")
D RECUR Q:GMR("OUT")
Q
RECUR ;
Q:$D(GMR("RECURSION")) S GMR("RECURSION")=1,GMR("Y")=Y,Y=GMR(GMR("LEVEL")),GMR("LEVEL")=1 S GMR("X")=""
S GMR("SPC")=GMR("SPC")+11 D RECUR1
K GMR("RECURSION"),GMR("FL",GMR("LEVEL")) S Y=GMR("Y"),GMR("LEVEL")=0
Q
EN2 ; ENTRY FROM THE INPUT TRANSFORMS ON THE ADDITIONAL TEXT (#1) AND
; ASSOCIATED LEAD FRAME DATA (#2) FIELDS OF THE SELECTION MULTIPLE (#1)
; OF THE GMR TEXT (#124.3) FILE. TRANSFORM DISALLOWS ENTRY OF A
; SELECTION IF ITS PARENT IS FLAGGED AS DELETED.
S GMRGND(0)=$P(^GMR(124.3,DA(1),1,DA,0),"^"),GMRGND(1)=DA(1),GMRGND(4)=$S($D(^GMR(124.3,DA(1),0)):$P(^(0),U),1:"")
EN2A S GMRGSTAT="" F GMRGND(3)=0:0 S GMRGND(3)=$O(^GMRD(124.2,"AKID",GMRGND(0),GMRGND(3))) Q:GMRGND(3)'>0 S GMRGST=$O(^GMR(124.3,GMRGND(1),1,"B",GMRGND(3),0)),GMRGST(1)=GMRGND(1) I GMRGST>0 D STAT^GMRGRUT0 Q:$P(GMRGSTAT,"^",3)
G:$P(GMRGSTAT,"^",3)!$D(^GMRD(124.2,"AKID",GMRGND(0),GMRGND(4))) Q2
W $C(7),!!,"PARENT PREVIOUSLY DELETED. PLEASE RE-CREATE PARENT ENTRY FIRST. " K X
Q2 K GMRGND,GMRGSTAT
Q
EN3 ; ENTRY FROM THE INPUT TRANSFORM ON THE MODIFICATION FIELD (#1) OF THE
; AUDIT TRAIL MULTIPLE (#3) OF THE SELECTION SUBFIELD (#1) OF THE GMR
; TEXT (#124.3) FILE. TRANSFORMS DISALLOWS ENTRY OF AND AUDIT IF ITS
; SELECTION'S PARENT HAS BEEN FLAGGED AS DELETED.
S GMRGND(0)=$P(^GMR(124.3,DA(2),1,DA(1),0),"^"),GMRGND(1)=DA(2),GMRGND(4)=$S($D(^GMR(124.3,DA(2),0)):$P(^(0),U),1:"") D EN2A
Q3 Q
DEL5 ;KILL LOGIC
F GMRG(1)=0:0 S GMRG(1)=$O(^DD(124.21,GMRG(3),1,GMRG(1))) Q:GMRG(1)'>0 X:$D(^DD(124.21,GMRG(3),1,GMRG(1),2)) ^(2)
S $P(^GMRD(124.2,DA(1),1,DA,0),"^",GMRG(3)+1)=""
Q
SET5 ;SET LOGIC
S $P(^GMRD(124.2,DA(1),1,DA,0),"^",GMRG(3)+1)=X
F GMRG(1)=0:0 S GMRG(1)=$O(^DD(124.21,GMRG(3),1,GMRG(1))) Q:GMRG(1)'>0 X:$D(^DD(124.21,GMRG(3),1,GMRG(1),1)) ^(1)
Q
EN4 ; ENTRY FROM THE C XREF OF THE .01 FIELD OF THE 124.2 FILE SET LOGIC
D UPCS
S ^GMRD(124.2,"C",GMRGUPX,DA)=""
K GMRGUPX
Q
EN5 ; ENTRY FROM THE C XREF OF THE .01 FIELD OF THE 124.2 FILE KILL LOGIC
D UPCS
K ^GMRD(124.2,"C",GMRGUPX,DA)
K GMRUPX
Q
UPCS ;
S GMRGUPX=X F GMRGUPX(0)=1:1:$L(X) I $E(X,GMRGUPX(0))?1L S GMRGUPX=$E(GMRGUPX,1,GMRGUPX(0)-1)_$C($A($E(X,GMRGUPX(0)))-32)_$E(GMRGUPX,GMRGUPX(0)+1,$L(X))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRGUT3 3901 printed Dec 13, 2024@01:55:44 Page 2
GMRGUT3 ;CISC/RM-UTILITIES ROUTINE FOR GMRG FILES (CONT.) ;5/28/92
+1 ;;3.0;Text Generator;;Jan 24, 1996
EN1 ; ENTRY FROM IDENTIFIER NODE FOR PARENT
+1 if $DATA(DX)#2
SET GMR("DX")=DX
if $DATA(DY)#2
SET GMR("DY")=DY
SET GMR("SPC")=5
SET GMR("LEVEL")=0
SET GMR("%")=$SELECT($DATA(IOSL):IOSL-5,1:19)
SET GMR("OUT")=0
DO RECUR1
+2 IF GMR("OUT")
SET DX=$SELECT($X'>80:$X,1:80)
SET DY=$SELECT('$DATA(DZ):0,DZ'?1"?".E:0,1:GMR("%")+5)
XECUTE ^%ZOSF("XY")
+3 if $DATA(GMR("DX"))
SET DX=GMR("DX")
if $DATA(GMR("DY"))
SET DY=GMR("DY")
KILL GMR
WRITE @("$E("_DIC_"Y,0),0)")
+4 QUIT
RECUR1 ;
+1 SET GMR("DATA")=$SELECT($DATA(^GMRD(124.2,+Y,0)):^(0),1:"")
WRITE !?GMR("SPC")," ",$SELECT($PIECE(GMR("DATA"),U,2)="":"",$PIECE(GMR("DATA"),U,2)=2:"FRAME",1:"TERM")
+2 WRITE ?(GMR("SPC")+8)," ",$PIECE(GMR("DATA"),U,3)
+3 WRITE ?(GMR("SPC")+16)," ",$SELECT($DATA(^GMRD(124.25,+$PIECE(GMR("DATA"),U,4),0)):$PIECE(^(0),"^"),1:"")
+4 if $Y>GMR("%")
DO EOP
if GMR("OUT")
QUIT
+5 DO E2
if GMR("OUT")
QUIT
SET GMR("SPC")=GMR("SPC")-11
+6 QUIT
EOP ;
+1 SET DX=$SELECT($X'>80:$X,1:80)
SET DY=0
SET $PIECE(GMR("%"),"^",2)=1
XECUTE ^%ZOSF("XY")
WRITE !?3,"Type an '^' to stop the parent list for this term: "
READ GMR("^"):DTIME
IF GMR("^")="^"!(GMR("^")="^^")!'$TEST
SET GMR("OUT")=1
QUIT
+2 QUIT
E2 ;
+1 FOR GMR(GMR("LEVEL"))=0:0
SET GMR(GMR("LEVEL"))=$ORDER(^GMRD(124.2,"AKID",+Y,GMR(GMR("LEVEL"))))
if GMR(GMR("LEVEL"))'>0!GMR("OUT")
QUIT
IF $DATA(^(GMR(GMR("LEVEL")),0))
DO CWR
if GMR("OUT")
QUIT
+2 QUIT
CWR ;
+1 SET GMR("L")=$ORDER(^GMRD(124.2,GMR(GMR("LEVEL")),1,"B",+Y,0))
if $SELECT(GMR("L")'>0
DO WRTID
+2 QUIT
WRTID ;
+1 WRITE !
if '$DATA(GMR("FL",GMR("LEVEL")))
WRITE ?(GMR("SPC")+3),"PARENT: "
if $DATA(^GMRD(124.2,GMR(GMR("LEVEL")),0))
WRITE ?(GMR("SPC")+11),$PIECE(^GMRD(124.2,GMR(GMR("LEVEL")),0),U)
SET GMR("FL",GMR("LEVEL"))=1
+2 if $Y>GMR("%")
DO EOP
if GMR("OUT")
QUIT
+3 DO RECUR
if GMR("OUT")
QUIT
+4 QUIT
RECUR ;
+1 if $DATA(GMR("RECURSION"))
QUIT
SET GMR("RECURSION")=1
SET GMR("Y")=Y
SET Y=GMR(GMR("LEVEL"))
SET GMR("LEVEL")=1
SET GMR("X")=""
+2 SET GMR("SPC")=GMR("SPC")+11
DO RECUR1
+3 KILL GMR("RECURSION"),GMR("FL",GMR("LEVEL"))
SET Y=GMR("Y")
SET GMR("LEVEL")=0
+4 QUIT
EN2 ; ENTRY FROM THE INPUT TRANSFORMS ON THE ADDITIONAL TEXT (#1) AND
+1 ; ASSOCIATED LEAD FRAME DATA (#2) FIELDS OF THE SELECTION MULTIPLE (#1)
+2 ; OF THE GMR TEXT (#124.3) FILE. TRANSFORM DISALLOWS ENTRY OF A
+3 ; SELECTION IF ITS PARENT IS FLAGGED AS DELETED.
+4 SET GMRGND(0)=$PIECE(^GMR(124.3,DA(1),1,DA,0),"^")
SET GMRGND(1)=DA(1)
SET GMRGND(4)=$SELECT($DATA(^GMR(124.3,DA(1),0)):$PIECE(^(0),U),1:"")
EN2A SET GMRGSTAT=""
FOR GMRGND(3)=0:0
SET GMRGND(3)=$ORDER(^GMRD(124.2,"AKID",GMRGND(0),GMRGND(3)))
if GMRGND(3)'>0
QUIT
SET GMRGST=$ORDER(^GMR(124.3,GMRGND(1),1,"B",GMRGND(3),0))
SET GMRGST(1)=GMRGND(1)
IF GMRGST>0
DO STAT^GMRGRUT0
if $PIECE(GMRGSTAT,"^",3)
QUIT
+1 if $PIECE(GMRGSTAT,"^",3)!$DATA(^GMRD(124.2,"AKID",GMRGND(0),GMRGND(4)))
GOTO Q2
+2 WRITE $CHAR(7),!!,"PARENT PREVIOUSLY DELETED. PLEASE RE-CREATE PARENT ENTRY FIRST. "
KILL X
Q2 KILL GMRGND,GMRGSTAT
+1 QUIT
EN3 ; ENTRY FROM THE INPUT TRANSFORM ON THE MODIFICATION FIELD (#1) OF THE
+1 ; AUDIT TRAIL MULTIPLE (#3) OF THE SELECTION SUBFIELD (#1) OF THE GMR
+2 ; TEXT (#124.3) FILE. TRANSFORMS DISALLOWS ENTRY OF AND AUDIT IF ITS
+3 ; SELECTION'S PARENT HAS BEEN FLAGGED AS DELETED.
+4 SET GMRGND(0)=$PIECE(^GMR(124.3,DA(2),1,DA(1),0),"^")
SET GMRGND(1)=DA(2)
SET GMRGND(4)=$SELECT($DATA(^GMR(124.3,DA(2),0)):$PIECE(^(0),U),1:"")
DO EN2A
Q3 QUIT
DEL5 ;KILL LOGIC
+1 FOR GMRG(1)=0:0
SET GMRG(1)=$ORDER(^DD(124.21,GMRG(3),1,GMRG(1)))
if GMRG(1)'>0
QUIT
if $DATA(^DD(124.21,GMRG(3),1,GMRG(1),2))
XECUTE ^(2)
+2 SET $PIECE(^GMRD(124.2,DA(1),1,DA,0),"^",GMRG(3)+1)=""
+3 QUIT
SET5 ;SET LOGIC
+1 SET $PIECE(^GMRD(124.2,DA(1),1,DA,0),"^",GMRG(3)+1)=X
+2 FOR GMRG(1)=0:0
SET GMRG(1)=$ORDER(^DD(124.21,GMRG(3),1,GMRG(1)))
if GMRG(1)'>0
QUIT
if $DATA(^DD(124.21,GMRG(3),1,GMRG(1),1))
XECUTE ^(1)
+3 QUIT
EN4 ; ENTRY FROM THE C XREF OF THE .01 FIELD OF THE 124.2 FILE SET LOGIC
+1 DO UPCS
+2 SET ^GMRD(124.2,"C",GMRGUPX,DA)=""
+3 KILL GMRGUPX
+4 QUIT
EN5 ; ENTRY FROM THE C XREF OF THE .01 FIELD OF THE 124.2 FILE KILL LOGIC
+1 DO UPCS
+2 KILL ^GMRD(124.2,"C",GMRGUPX,DA)
+3 KILL GMRUPX
+4 QUIT
UPCS ;
+1 SET GMRGUPX=X
FOR GMRGUPX(0)=1:1:$LENGTH(X)
IF $EXTRACT(X,GMRGUPX(0))?1L
SET GMRGUPX=$EXTRACT(GMRGUPX,1,GMRGUPX(0)-1)_$CHAR($ASCII($EXTRACT(X,GMRGUPX(0)))-32)_$EXTRACT(GMRGUPX,GMRGUPX(0)+1,$LENGTH(X))
+2 QUIT
