GMRGED3 ;HIRMFO/RM-PATIENT DATA EDIT (cont.) ;9/1/95
;;3.0;Text Generator;;Jan 24, 1996
EN1 ; REPLACE/WITH TEXT GMRGTX(0)=TEXT TO BE EDITED, GMRGTX(1)=1 FOR
; INTERNAL TEXT, 0 FOR OTHER KINDS
REPLACE W ?$X+2,GMRGTX(0),!?4,"Replace " R GMRG1:DTIME S:GMRG1="^"!(GMRG1="^^")!'$T GMRGOUT=1 Q:GMRGOUT!(GMRG1="") I GMRG1?1"?".E D REPHLP W ! G REPLACE
I GMRG1["@" D DEL Q:GMRGTX(0)=""!GMRGOUT W ! G REPLACE
D:GMRG1["..." RANGE
S GMRG2=GMRG1,GMRG3=$S(GMRG2="":0,GMRGTX(0)[GMRG2:1,1:0) W:'GMRG3 $C(7)," ??",!
I GMRG3 D WITH Q:GMRGTX(0)=""!GMRGOUT W ! G REPLACE
W ! G REPLACE
REPHLP W !!?5,"At the ""Replace"" prompt, enter exactly the text you want to replace.",!?5,"You may also enter ""..."" to replace the entire text, ""...(text)"" to",!?5,"replace from the beginning through ""(text)"", or ""(text)..."" to replace"
W !?5,"from ""(text)"" through the end.",!?5,"At the ""With"" prompt, enter the new text.",!?10
Q
WITH W " With " R GMRG4:DTIME S:GMRG4="^"!(GMRG4="^^")!'$T GMRGOUT=1 Q:GMRGOUT I GMRG4?1"?".E D REPHLP G WITH
S GMRGTX(2)=$P(GMRGTX(0),GMRG1)_GMRG4_$P(GMRGTX(0),GMRG1,2,$L(GMRGTX(0),GMRG1)) I GMRGTX(2)="" D DEL Q:GMRGOUT I GMRGTX(0)'="" W $C(7)," ??" Q
Q:GMRGOUT S GMRGTX(0)=GMRGTX(2)
Q
RANGE S GMRG5=$P(GMRG1,"..."),GMRG7=$F(GMRGTX(0),GMRG5),GMRG5(0)=$S(GMRG5'=""&GMRG7:GMRG7-$L(GMRG5),'GMRG7:0,1:1)
S GMRG6=$P(GMRG1,"...",2),GMRG8=$F(GMRGTX(0),GMRG6,GMRG7),GMRG6(0)=$S('GMRG8!'GMRG7:0,GMRG6'="":GMRG8-1,1:$L(GMRGTX(0))),GMRG1=$E(GMRGTX(0),GMRG5(0),GMRG6(0))
Q
DEL ; DELETE EXISTING TEXT
I 'GMRGTX("@") W !,$C(7),"CANNOT DELETE!!" Q
I GMRGTX(1) W !?5,$C(7),"If you delete bracketed text, the original default will become the",!?5,"the new value."
W !?5,$C(7),"WANT TO DELETE" S %=0 D YN^DICN S:%=1 GMRGTX(0)="" S:%=-1 GMRGOUT=1 Q:%'=0 W !?6,"Answer Yes if you wish to delete this text, else answer No." G DEL
Q
VALIDATE ; VALIDATE USER SELECTION ENTRY
F GMRG1=1:1 S GMRG2=$P(GMRGS,",",GMRG1) Q:GMRG2="" S:GMRG2="a" GMRG2="A" D VAL0 Q:'GMRGOOD
Q
VAL0 ; VALIDATION CONT.
I GMRG2["-" S GMRG3=$P(GMRG2,"-"),GMRG2=$P(GMRG2,"-",2),GMRG5=1 S:GMRG2="a" GMRG2="A"
E S GMRG3=$S(GMRG2'="A":+GMRG2,1:GMRG2),GMRG5=0
I '(GMRG3?1N.N!('GMRG5&(GMRG3="A"))!(GMRG3>0)) S GMRGOOD=0 Q
I GMRG5,GMRG2="A" S GMRGOOD=0 Q
S:GMRG2?1N.N1"/;" GMRG2=+GMRG2_";/"
I GMRG2?1N.N!(GMRG2?1N.N1"@")!(GMRG2?1N.N1";")!(GMRG2?1N.N1"/")!(GMRG2?1N.N1"/;")!(GMRG2?1N.N1";/")!(GMRG2="A") D VAL1 Q
I 'GMRG5,(GMRG2?1N.N1";".E!(GMRG2?1N.N1"/".E)) D VALTXT Q ;S GMRG6=$S(GMRG2?1N.N1";".E:";",1:"/"),GMRG4=$P(GMRG2,GMRG6,2,99) S:GMRG6=";"&(GMRG4'="")&($P(GMRGSEL(+GMRG2),"^",2)["]") GMRGOOD=0 Q:'GMRGOOD D VAL1 Q
S GMRGOOD=0
Q
VAL1 ;
I GMRG2="A" S GMRGQUSL("A")=1 Q
I +GMRG2<1!(+GMRG2>GMRGSTAR(1))!(+GMRG2<GMRG3)!(GMRG3<1)!(GMRG3>GMRGSTAR(1)) S GMRGOOD=0 Q
F GMRG10=GMRG3:1:+GMRG2 S:$S('$D(GMRGSEL(GMRG10)):1,GMRG2["/"&($P(GMRGSEL(GMRG10),"^",2)'["]"):1,1:0) GMRGOOD=0 Q:'GMRGOOD S GMRGQUSL(GMRG10)=$P(GMRG2,+GMRG2,2,$L(GMRG2,+GMRG2))
Q
VALTXT ;
I +GMRG2<1!(+GMRG2>GMRGSTAR(1)) S GMRGOOD=0 Q
K GMRG4 S (GMRG12,GMRG13,GMRG11)=0,GMRG14=$L($P(GMRGSEL(+GMRG2),"^",2),"]")-1
F GMRG6=0:0 S GMRG12=$S('GMRG11:$F(GMRG2,";",GMRG12),1:0),GMRG13=$S(GMRG14>0:$F(GMRG2,"/",GMRG13),1:0),GMRG6=GMRG12!GMRG13 Q:GMRG6'>0 D STXT
S GMRG11=0
F GMRG6=0:0 S GMRG6=$O(GMRG4(GMRG6)),GMRG13=$O(GMRG4(GMRG6)),GMRG13=$S(GMRG13>0:GMRG13-1,1:$L(GMRG2)) Q:GMRG6'>0 D STXT1
S GMRG14=$P($G(GMRGSEL(+GMRG2,1)),"^",2),GMRG12=$L($G(GMRG4("A"))) F GMRG6=1:1:$L($P(GMRGSEL(+GMRG2),"^",2),"]")-1 S GMRG12=GMRG12+$L($S($D(GMRG4("I",GMRG6)):GMRG4("I",GMRG6),1:$P(GMRG14,"|",GMRG6+1)))+1
I GMRG12>175 S GMRGOOD=0 Q
S GMRG2=+GMRG2_$G(GMRG4("A")) F GMRG6=0:0 S GMRG6=$O(GMRG4("I",GMRG6)) Q:GMRG6'>0 S GMRG2=GMRG2_$G(GMRG4("I",GMRG6))
S GMRGQUSL(+GMRG2)=$P(GMRG2,+GMRG2,2,$L(GMRG2,+GMRG2))
Q
STXT ;
S:GMRG12>0 GMRG11=1 S:GMRG13>0 GMRG14=GMRG14-1
S:GMRG13>0 GMRG4(GMRG13-1)="I"
S:GMRG12>0 GMRG4(GMRG12-1)="A"
Q
STXT1 ;
S:GMRG4(GMRG6)="I" GMRG11=GMRG11+1,GMRG4("I",GMRG11)=$E(GMRG2,GMRG6,GMRG13)
S:GMRG4(GMRG6)="A" GMRG4("A")=$E(GMRG2,GMRG6,GMRG13)
Q
PROMPT ;
I $P(GMRGTERM(0),"^",6)=""&($P(GMRGTERM(0),"^",7)="") W "Select: " Q
I $P(GMRGTERM(0),"^",7)="" W "Select at least ",$P(GMRGTERM(0),"^",6),": " Q
I $P(GMRGTERM(0),"^",6)="" W "Select up to ",$P(GMRGTERM(0),"^",7),": " Q
I $P(GMRGTERM(0),"^",6)'=$P(GMRGTERM(0),"^",7) W "Select at least ",$P(GMRGTERM(0),"^",6),", but no more than ",$P(GMRGTERM(0),"^",7),": "
E W "Select only ",$P(GMRGTERM(0),"^",6),": "
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRGED3 4527 printed Oct 16, 2024@17:55:58 Page 2
GMRGED3 ;HIRMFO/RM-PATIENT DATA EDIT (cont.) ;9/1/95
+1 ;;3.0;Text Generator;;Jan 24, 1996
EN1 ; REPLACE/WITH TEXT GMRGTX(0)=TEXT TO BE EDITED, GMRGTX(1)=1 FOR
+1 ; INTERNAL TEXT, 0 FOR OTHER KINDS
REPLACE WRITE ?$X+2,GMRGTX(0),!?4,"Replace "
READ GMRG1:DTIME
if GMRG1="^"!(GMRG1="^^")!'$TEST
SET GMRGOUT=1
if GMRGOUT!(GMRG1="")
QUIT
IF GMRG1?1"?".E
DO REPHLP
WRITE !
GOTO REPLACE
+1 IF GMRG1["@"
DO DEL
if GMRGTX(0)=""!GMRGOUT
QUIT
WRITE !
GOTO REPLACE
+2 if GMRG1["..."
DO RANGE
+3 SET GMRG2=GMRG1
SET GMRG3=$SELECT(GMRG2="":0,GMRGTX(0)[GMRG2:1,1:0)
if 'GMRG3
WRITE $CHAR(7)," ??",!
+4 IF GMRG3
DO WITH
if GMRGTX(0)=""!GMRGOUT
QUIT
WRITE !
GOTO REPLACE
+5 WRITE !
GOTO REPLACE
REPHLP WRITE !!?5,"At the ""Replace"" prompt, enter exactly the text you want to replace.",!?5,"You may also enter ""..."" to replace the entire text, ""...(text)"" to",!?5,"replace from the beginning through ""(text)"", or ""(text)..."" to replace"
+1 WRITE !?5,"from ""(text)"" through the end.",!?5,"At the ""With"" prompt, enter the new text.",!?10
+2 QUIT
WITH WRITE " With "
READ GMRG4:DTIME
if GMRG4="^"!(GMRG4="^^")!'$TEST
SET GMRGOUT=1
if GMRGOUT
QUIT
IF GMRG4?1"?".E
DO REPHLP
GOTO WITH
+1 SET GMRGTX(2)=$PIECE(GMRGTX(0),GMRG1)_GMRG4_$PIECE(GMRGTX(0),GMRG1,2,$LENGTH(GMRGTX(0),GMRG1))
IF GMRGTX(2)=""
DO DEL
if GMRGOUT
QUIT
IF GMRGTX(0)'=""
WRITE $CHAR(7)," ??"
QUIT
+2 if GMRGOUT
QUIT
SET GMRGTX(0)=GMRGTX(2)
+3 QUIT
RANGE SET GMRG5=$PIECE(GMRG1,"...")
SET GMRG7=$FIND(GMRGTX(0),GMRG5)
SET GMRG5(0)=$SELECT(GMRG5'=""&GMRG7:GMRG7-$LENGTH(GMRG5),'GMRG7:0,1:1)
+1 SET GMRG6=$PIECE(GMRG1,"...",2)
SET GMRG8=$FIND(GMRGTX(0),GMRG6,GMRG7)
SET GMRG6(0)=$SELECT('GMRG8!'GMRG7:0,GMRG6'="":GMRG8-1,1:$LENGTH(GMRGTX(0)))
SET GMRG1=$EXTRACT(GMRGTX(0),GMRG5(0),GMRG6(0))
+2 QUIT
DEL ; DELETE EXISTING TEXT
+1 IF 'GMRGTX("@")
WRITE !,$CHAR(7),"CANNOT DELETE!!"
QUIT
+2 IF GMRGTX(1)
WRITE !?5,$CHAR(7),"If you delete bracketed text, the original default will become the",!?5,"the new value."
+3 WRITE !?5,$CHAR(7),"WANT TO DELETE"
SET %=0
DO YN^DICN
if %=1
SET GMRGTX(0)=""
if %=-1
SET GMRGOUT=1
if %'=0
QUIT
WRITE !?6,"Answer Yes if you wish to delete this text, else answer No."
GOTO DEL
+4 QUIT
VALIDATE ; VALIDATE USER SELECTION ENTRY
+1 FOR GMRG1=1:1
SET GMRG2=$PIECE(GMRGS,",",GMRG1)
if GMRG2=""
QUIT
if GMRG2="a"
SET GMRG2="A"
DO VAL0
if 'GMRGOOD
QUIT
+2 QUIT
VAL0 ; VALIDATION CONT.
+1 IF GMRG2["-"
SET GMRG3=$PIECE(GMRG2,"-")
SET GMRG2=$PIECE(GMRG2,"-",2)
SET GMRG5=1
if GMRG2="a"
SET GMRG2="A"
+2 IF '$TEST
SET GMRG3=$SELECT(GMRG2'="A":+GMRG2,1:GMRG2)
SET GMRG5=0
+3 IF '(GMRG3?1N.N!('GMRG5&(GMRG3="A"))!(GMRG3>0))
SET GMRGOOD=0
QUIT
+4 IF GMRG5
IF GMRG2="A"
SET GMRGOOD=0
QUIT
+5 if GMRG2?1N.N1"/;"
SET GMRG2=+GMRG2_";/"
+6 IF GMRG2?1N.N!(GMRG2?1N.N1"@")!(GMRG2?1N.N1";")!(GMRG2?1N.N1"/")!(GMRG2?1N.N1"/;")!(GMRG2?1N.N1";/")!(GMRG2="A")
DO VAL1
QUIT
+7 ;S GMRG6=$S(GMRG2?1N.N1";".E:";",1:"/"),GMRG4=$P(GMRG2,GMRG6,2,99) S:GMRG6=";"&(GMRG4'="")&($P(GMRGSEL(+GMRG2),"^",2)["]") GMRGOOD=0 Q:'GMRGOOD D VAL1 Q
IF 'GMRG5
IF (GMRG2?1N.N1";".E!(GMRG2?1N.N1"/".E))
DO VALTXT
QUIT
+8 SET GMRGOOD=0
+9 QUIT
VAL1 ;
+1 IF GMRG2="A"
SET GMRGQUSL("A")=1
QUIT
+2 IF +GMRG2<1!(+GMRG2>GMRGSTAR(1))!(+GMRG2<GMRG3)!(GMRG3<1)!(GMRG3>GMRGSTAR(1))
SET GMRGOOD=0
QUIT
+3 FOR GMRG10=GMRG3:1:+GMRG2
if $SELECT('$DATA(GMRGSEL(GMRG10))
SET GMRGOOD=0
if 'GMRGOOD
QUIT
SET GMRGQUSL(GMRG10)=$PIECE(GMRG2,+GMRG2,2,$LENGTH(GMRG2,+GMRG2))
+4 QUIT
VALTXT ;
+1 IF +GMRG2<1!(+GMRG2>GMRGSTAR(1))
SET GMRGOOD=0
QUIT
+2 KILL GMRG4
SET (GMRG12,GMRG13,GMRG11)=0
SET GMRG14=$LENGTH($PIECE(GMRGSEL(+GMRG2),"^",2),"]")-1
+3 FOR GMRG6=0:0
SET GMRG12=$SELECT('GMRG11:$FIND(GMRG2,";",GMRG12),1:0)
SET GMRG13=$SELECT(GMRG14>0:$FIND(GMRG2,"/",GMRG13),1:0)
SET GMRG6=GMRG12!GMRG13
if GMRG6'>0
QUIT
DO STXT
+4 SET GMRG11=0
+5 FOR GMRG6=0:0
SET GMRG6=$ORDER(GMRG4(GMRG6))
SET GMRG13=$ORDER(GMRG4(GMRG6))
SET GMRG13=$SELECT(GMRG13>0:GMRG13-1,1:$LENGTH(GMRG2))
if GMRG6'>0
QUIT
DO STXT1
+6 SET GMRG14=$PIECE($GET(GMRGSEL(+GMRG2,1)),"^",2)
SET GMRG12=$LENGTH($GET(GMRG4("A")))
FOR GMRG6=1:1:$LENGTH($PIECE(GMRGSEL(+GMRG2),"^",2),"]")-1
SET GMRG12=GMRG12+$LENGTH($SELECT($DATA(GMRG4("I",GMRG6)):GMRG4("I",GMRG6),1:$PIECE(GMRG14,"|",GMRG6+1)))+1
+7 IF GMRG12>175
SET GMRGOOD=0
QUIT
+8 SET GMRG2=+GMRG2_$GET(GMRG4("A"))
FOR GMRG6=0:0
SET GMRG6=$ORDER(GMRG4("I",GMRG6))
if GMRG6'>0
QUIT
SET GMRG2=GMRG2_$GET(GMRG4("I",GMRG6))
+9 SET GMRGQUSL(+GMRG2)=$PIECE(GMRG2,+GMRG2,2,$LENGTH(GMRG2,+GMRG2))
+10 QUIT
STXT ;
+1 if GMRG12>0
SET GMRG11=1
if GMRG13>0
SET GMRG14=GMRG14-1
+2 if GMRG13>0
SET GMRG4(GMRG13-1)="I"
+3 if GMRG12>0
SET GMRG4(GMRG12-1)="A"
+4 QUIT
STXT1 ;
+1 if GMRG4(GMRG6)="I"
SET GMRG11=GMRG11+1
SET GMRG4("I",GMRG11)=$EXTRACT(GMRG2,GMRG6,GMRG13)
+2 if GMRG4(GMRG6)="A"
SET GMRG4("A")=$EXTRACT(GMRG2,GMRG6,GMRG13)
+3 QUIT
PROMPT ;
+1 IF $PIECE(GMRGTERM(0),"^",6)=""&($PIECE(GMRGTERM(0),"^",7)="")
WRITE "Select: "
QUIT
+2 IF $PIECE(GMRGTERM(0),"^",7)=""
WRITE "Select at least ",$PIECE(GMRGTERM(0),"^",6),": "
QUIT
+3 IF $PIECE(GMRGTERM(0),"^",6)=""
WRITE "Select up to ",$PIECE(GMRGTERM(0),"^",7),": "
QUIT
+4 IF $PIECE(GMRGTERM(0),"^",6)'=$PIECE(GMRGTERM(0),"^",7)
WRITE "Select at least ",$PIECE(GMRGTERM(0),"^",6),", but no more than ",$PIECE(GMRGTERM(0),"^",7),": "
+5 IF '$TEST
WRITE "Select only ",$PIECE(GMRGTERM(0),"^",6),": "
+6 QUIT
