GMRGED6 ;CISC/RM-PATIENT DATA EDIT (cont.) ;4/25/89
;;3.0;Text Generator;;Jan 24, 1996
INTERNAL ; EDIT INTERNAL TEXT FOR THE SELECTED ENTRY.
S (GMRGTX("OL"),GMRGTX)=$P(GMRGPRC(0),"^",3),GMRGTX("ACTION")=$P($P(GMRGPRC,"^",2),"/",2,999)
I GMRGTX("ACTION")="" D INTP
I GMRGTX("ACTION")'="" F X=1:1:$L($P(GMRGPRC(0),"^"),"]")-1 S $P(GMRGTX,"|",X+1)=$P(GMRGTX("ACTION"),"/",X,$S(X=($L($P(GMRGPRC(0),"^"),"]")-1):999,1:X))
I 'GMRGOUT,GMRGTX("OL")'=GMRGTX S X=GMRGTX("OL"),DA=$P(GMRGPRC(0),"^",2),DA(1)=GMRGPDA,GMRGY=2,GMRGAT=0,GMRGZ="" D EN1^GMRGUTL K GMRGAT,GMRGZ S $P(^GMR(124.3,DA(1),1,DA,0),"^",2)=GMRGTX,$P(GMRGPRC(0),"^",3)=GMRGTX
I 'GMRGOUT,GMRGTX("OL")'=GMRGTX S ^TMP($J,"GMRGLVL",$P(GMRGLVL,"^"),GMRGTLVL,GMRGSLVL,0)=GMRGPRC(0)
Q
INTP ;
W !!,"INTERNAL TEXT for '" S GMRGXPRT=$P(GMRGPRC(0),"^"),GMRGXPRT(0)=$P(GMRGPRC(0),"^",3),GMRGXPRT(1)="19^"_IOM_"^1^0" D EN1^GMRGRUT2 W "'"
F GMRG10=1:1:$L($P(GMRGPRC(0),"^"),"]")-1 D INTXED Q:GMRGOUT S $P(GMRGTX,"|",GMRG10+1)=GMRGTX(0)
Q
INTXED ;
S GMRGTX("DEF")=$P($P($P(GMRGPRC(0),"^"),"]",GMRG10),"[",2) F X=1:1:$L(GMRGTX("DEF")) Q:$E(GMRGTX("DEF"),X)'=" " S GMRGTX("DEF")=$E(GMRGTX("DEF"),2,$L(GMRGTX("DEF")))
S (GMRGTX("OLD"),GMRGTX(0))=$S($P(GMRGTX,"|",GMRG10+1)="":GMRGTX("DEF"),1:$P(GMRGTX,"|",GMRG10+1))
INTX0 ;
I $L(GMRGTX(0))>15 S (GMRGTX("@"),GMRGTX(1))=1 W ! D EN1^GMRGED3 S:GMRGTX(0)="" GMRGTX(0)=GMRGTX("DEF") G INTX1
W !,"Internal Text Number ",GMRG10,": ",$S($L(GMRGTX(0)):GMRGTX(0)_"// ",1:"") R GMRGTX(0):DTIME
S:GMRGTX(0)=""&$L(GMRGTX("OLD")) GMRGTX(0)=GMRGTX("OLD") S:GMRGTX(0)="^"!(GMRGTX(0)="^^")!'$T GMRGOUT=1 Q:GMRGOUT!(GMRGTX(0)="") G:GMRGTX(0)'="@" INTX1
YNIP W !?4,$C(7),"WANT TO DELETE" S %=1 D YN^DICN S:%=-1 GMRGOUT=1 Q:GMRGOUT W:%=2 $C(7)," ??" S GMRGTX(0)=$S(%=2:GMRGTX("OLD"),%=1:"",1:GMRGTX(0))
G INTX0:%=2,INTX1:%=1 W !?8,$C(7),"Answer Yes if you want to delete the appended text, else answer No.",!!?8,"NOTE: If you delete bracketed text, the original default will become",!?8,"the new value." G YNIP
INTX1 I $L(($P(GMRGTX,"|",1,GMRG10)_"|"_GMRGTX(0)_"|"_$P(GMRGTX,"|",GMRG10+2,$L(GMRGTX,"|"))))>175 W !,?4,$C(7),"LINE TOO LONG??" S GMRGTX(0)=GMRGTX("OLD") G INTX0
I GMRGTX(0)["^"!(GMRGTX(0)?1"?".E) W !?4,$C(7),$S(GMRGTX(0)?1"?".E:"ANSWER WITH FREE TEXT",1:"ANSWER CANNOT CONTAIN THE CIRCUMFLEX '^' CHARACTER") S GMRGTX(0)=GMRGTX("OLD") G INTX0
Q
DELETE ;
S GMRGDFLG=1,X=$P(GMRGPRC,"^"),DA(1)=GMRGPDA,DA=$P(GMRGPRC(0),"^",2) I DA'>0 K DA Q
S GMRGY=0 D EN1^GMRGUTL
K GMRGDFLG S GMRGART=0 X:$D(^GMRD(124.2,$P(GMRGPRC,"^"),8)) ^(8) Q:GMRGOUT
Q
STUT ;
I GMRG0["*"!(GMRG0["T") D JSTCK^GMRGED9 Q
S GMRG3=0 I $P(GMRGPRC,"^",2)="S",GMRG0'="A" S GMRG3=+$O(^GMRD(124.4,GMRGTPLT,1,"B",+GMRGSEL(GMRG0),0)),GMRG3=$S($D(^GMRD(124.4,GMRGTPLT,1,GMRG3,0)):10+$P(^(0),"^",3),1:0)
S ^TMP($J,"GMRGLVL",$P(GMRGLVL,"^"),GMRGTLVL,GMRG2)=$S(GMRG0'="A":$P(GMRGSEL(GMRG0),"^")_"^"_GMRGUSL(GMRG0),1:"A^"_GMRGTERM)_"^"_GMRG3
S:GMRG0'="A" ^TMP($J,"GMRGLVL",$P(GMRGLVL,"^"),GMRGTLVL,GMRG2,0)=$P(GMRGSEL(GMRG0),"^",2)_"^"_$S($D(GMRGSEL(GMRG0,1)):GMRGSEL(GMRG0,1),1:"")
Q
PRCTRM ;
Q:+GMRGTERM=+GMRGRT K DA S DA(1)=GMRGPDA,DA=$P(GMRGTERM,"^",3)
S GMRGND=GMRGPDA,GMRGND(0)=$P(GMRGTERM,"^") D STLST^GMRGRUT0
I '$D(^GMR(124.3,DA(1),1,DA)) S ^(DA,0)=$P(GMRGTERM,"^")_"^^1",DIK="^GMR(124.3,"_DA(1)_",1," D IX1^DIK
I '$P(^GMR(124.3,DA(1),1,DA,0),"^",3) D ADS
Q
ADS ;
S X=0 F GMRG1=0:0 S GMRG1=$O(^DD(124.31,4,1,GMRG1)) Q:GMRG1'>0 X:$D(^DD(124.31,4,1,GMRG1,2)) ^(2)
S X=1,$P(^GMR(124.3,DA(1),1,DA,0),"^",3)=X F GMRG1=0:0 S GMRG1=$O(^DD(124.31,4,1,GMRG1)) Q:GMRG1'>0 X:$D(^DD(124.31,4,1,GMRG1,1)) ^(1)
S GMRGART=1 X:$D(^GMRD(124.2,$P(GMRGTERM,"^"),8)) ^(8)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRGED6 3689 printed Sep 23, 2025@19:31:22 Page 2
GMRGED6 ;CISC/RM-PATIENT DATA EDIT (cont.) ;4/25/89
+1 ;;3.0;Text Generator;;Jan 24, 1996
INTERNAL ; EDIT INTERNAL TEXT FOR THE SELECTED ENTRY.
+1 SET (GMRGTX("OL"),GMRGTX)=$PIECE(GMRGPRC(0),"^",3)
SET GMRGTX("ACTION")=$PIECE($PIECE(GMRGPRC,"^",2),"/",2,999)
+2 IF GMRGTX("ACTION")=""
DO INTP
+3 IF GMRGTX("ACTION")'=""
FOR X=1:1:$LENGTH($PIECE(GMRGPRC(0),"^"),"]")-1
SET $PIECE(GMRGTX,"|",X+1)=$PIECE(GMRGTX("ACTION"),"/",X,$SELECT(X=($LENGTH($PIECE(GMRGPRC(0),"^"),"]")-1):999,1:X))
+4 IF 'GMRGOUT
IF GMRGTX("OL")'=GMRGTX
SET X=GMRGTX("OL")
SET DA=$PIECE(GMRGPRC(0),"^",2)
SET DA(1)=GMRGPDA
SET GMRGY=2
SET GMRGAT=0
SET GMRGZ=""
DO EN1^GMRGUTL
KILL GMRGAT,GMRGZ
SET $PIECE(^GMR(124.3,DA(1),1,DA,0),"^",2)=GMRGTX
SET $PIECE(GMRGPRC(0),"^",3)=GMRGTX
+5 IF 'GMRGOUT
IF GMRGTX("OL")'=GMRGTX
SET ^TMP($JOB,"GMRGLVL",$PIECE(GMRGLVL,"^"),GMRGTLVL,GMRGSLVL,0)=GMRGPRC(0)
+6 QUIT
INTP ;
+1 WRITE !!,"INTERNAL TEXT for '"
SET GMRGXPRT=$PIECE(GMRGPRC(0),"^")
SET GMRGXPRT(0)=$PIECE(GMRGPRC(0),"^",3)
SET GMRGXPRT(1)="19^"_IOM_"^1^0"
DO EN1^GMRGRUT2
WRITE "'"
+2 FOR GMRG10=1:1:$LENGTH($PIECE(GMRGPRC(0),"^"),"]")-1
DO INTXED
if GMRGOUT
QUIT
SET $PIECE(GMRGTX,"|",GMRG10+1)=GMRGTX(0)
+3 QUIT
INTXED ;
+1 SET GMRGTX("DEF")=$PIECE($PIECE($PIECE(GMRGPRC(0),"^"),"]",GMRG10),"[",2)
FOR X=1:1:$LENGTH(GMRGTX("DEF"))
if $EXTRACT(GMRGTX("DEF"),X)'=" "
QUIT
SET GMRGTX("DEF")=$EXTRACT(GMRGTX("DEF"),2,$LENGTH(GMRGTX("DEF")))
+2 SET (GMRGTX("OLD"),GMRGTX(0))=$SELECT($PIECE(GMRGTX,"|",GMRG10+1)="":GMRGTX("DEF"),1:$PIECE(GMRGTX,"|",GMRG10+1))
INTX0 ;
+1 IF $LENGTH(GMRGTX(0))>15
SET (GMRGTX("@"),GMRGTX(1))=1
WRITE !
DO EN1^GMRGED3
if GMRGTX(0)=""
SET GMRGTX(0)=GMRGTX("DEF")
GOTO INTX1
+2 WRITE !,"Internal Text Number ",GMRG10,": ",$SELECT($LENGTH(GMRGTX(0)):GMRGTX(0)_"// ",1:"")
READ GMRGTX(0):DTIME
+3 if GMRGTX(0)=""&$LENGTH(GMRGTX("OLD"))
SET GMRGTX(0)=GMRGTX("OLD")
if GMRGTX(0)="^"!(GMRGTX(0)="^^")!'$TEST
SET GMRGOUT=1
if GMRGOUT!(GMRGTX(0)="")
QUIT
if GMRGTX(0)'="@"
GOTO INTX1
YNIP WRITE !?4,$CHAR(7),"WANT TO DELETE"
SET %=1
DO YN^DICN
if %=-1
SET GMRGOUT=1
if GMRGOUT
QUIT
if %=2
WRITE $CHAR(7)," ??"
SET GMRGTX(0)=$SELECT(%=2:GMRGTX("OLD"),%=1:"",1:GMRGTX(0))
+1 if %=2
GOTO INTX0
if %=1
GOTO INTX1
WRITE !?8,$CHAR(7),"Answer Yes if you want to delete the appended text, else answer No.",!!?8,"NOTE: If you delete bracketed text, the original default will become",!?8,"the new value."
GOTO YNIP
INTX1 IF $LENGTH(($PIECE(GMRGTX,"|",1,GMRG10)_"|"_GMRGTX(0)_"|"_$PIECE(GMRGTX,"|",GMRG10+2,$LENGTH(GMRGTX,"|"))))>175
WRITE !,?4,$CHAR(7),"LINE TOO LONG??"
SET GMRGTX(0)=GMRGTX("OLD")
GOTO INTX0
+1 IF GMRGTX(0)["^"!(GMRGTX(0)?1"?".E)
WRITE !?4,$CHAR(7),$SELECT(GMRGTX(0)?1"?".E:"ANSWER WITH FREE TEXT",1:"ANSWER CANNOT CONTAIN THE CIRCUMFLEX '^' CHARACTER")
SET GMRGTX(0)=GMRGTX("OLD")
GOTO INTX0
+2 QUIT
DELETE ;
+1 SET GMRGDFLG=1
SET X=$PIECE(GMRGPRC,"^")
SET DA(1)=GMRGPDA
SET DA=$PIECE(GMRGPRC(0),"^",2)
IF DA'>0
KILL DA
QUIT
+2 SET GMRGY=0
DO EN1^GMRGUTL
+3 KILL GMRGDFLG
SET GMRGART=0
if $DATA(^GMRD(124.2,$PIECE(GMRGPRC,"^"),8))
XECUTE ^(8)
if GMRGOUT
QUIT
+4 QUIT
STUT ;
+1 IF GMRG0["*"!(GMRG0["T")
DO JSTCK^GMRGED9
QUIT
+2 SET GMRG3=0
IF $PIECE(GMRGPRC,"^",2)="S"
IF GMRG0'="A"
SET GMRG3=+$ORDER(^GMRD(124.4,GMRGTPLT,1,"B",+GMRGSEL(GMRG0),0))
SET GMRG3=$SELECT($DATA(^GMRD(124.4,GMRGTPLT,1,GMRG3,0)):10+$PIECE(^(0),"^",3),1:0)
+3 SET ^TMP($JOB,"GMRGLVL",$PIECE(GMRGLVL,"^"),GMRGTLVL,GMRG2)=$SELECT(GMRG0'="A":$PIECE(GMRGSEL(GMRG0),"^")_"^"_GMRGUSL(GMRG0),1:"A^"_GMRGTERM)_"^"_GMRG3
+4 if GMRG0'="A"
SET ^TMP($JOB,"GMRGLVL",$PIECE(GMRGLVL,"^"),GMRGTLVL,GMRG2,0)=$PIECE(GMRGSEL(GMRG0),"^",2)_"^"_$SELECT($DATA(GMRGSEL(GMRG0,1)):GMRGSEL(GMRG0,1),1:"")
+5 QUIT
PRCTRM ;
+1 if +GMRGTERM=+GMRGRT
QUIT
KILL DA
SET DA(1)=GMRGPDA
SET DA=$PIECE(GMRGTERM,"^",3)
+2 SET GMRGND=GMRGPDA
SET GMRGND(0)=$PIECE(GMRGTERM,"^")
DO STLST^GMRGRUT0
+3 IF '$DATA(^GMR(124.3,DA(1),1,DA))
SET ^(DA,0)=$PIECE(GMRGTERM,"^")_"^^1"
SET DIK="^GMR(124.3,"_DA(1)_",1,"
DO IX1^DIK
+4 IF '$PIECE(^GMR(124.3,DA(1),1,DA,0),"^",3)
DO ADS
+5 QUIT
ADS ;
+1 SET X=0
FOR GMRG1=0:0
SET GMRG1=$ORDER(^DD(124.31,4,1,GMRG1))
if GMRG1'>0
QUIT
if $DATA(^DD(124.31,4,1,GMRG1,2))
XECUTE ^(2)
+2 SET X=1
SET $PIECE(^GMR(124.3,DA(1),1,DA,0),"^",3)=X
FOR GMRG1=0:0
SET GMRG1=$ORDER(^DD(124.31,4,1,GMRG1))
if GMRG1'>0
QUIT
if $DATA(^DD(124.31,4,1,GMRG1,1))
XECUTE ^(1)
+3 SET GMRGART=1
if $DATA(^GMRD(124.2,$PIECE(GMRGTERM,"^"),8))
XECUTE ^(8)
+4 QUIT
