source: FOIAVistA/trunk/r/GEN_MED_REC_GENERATOR-GMRG/GMRGED6.m@ 1397

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