- 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 Apr 23, 2025@18:09:43 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
