- 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
- 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
