source: WorldVistAEHR/trunk/r/GEN_MED_REC_GENERATOR-GMRG/GMRGED3.m@ 1766

Last change on this file since 1766 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.4 KB
Line 
1GMRGED3 ;HIRMFO/RM-PATIENT DATA EDIT (cont.) ;9/1/95
2 ;;3.0;Text Generator;;Jan 24, 1996
3EN1 ; REPLACE/WITH TEXT GMRGTX(0)=TEXT TO BE EDITED, GMRGTX(1)=1 FOR
4 ; INTERNAL TEXT, 0 FOR OTHER KINDS
5REPLACE 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
6 I GMRG1["@" D DEL Q:GMRGTX(0)=""!GMRGOUT W ! G REPLACE
7 D:GMRG1["..." RANGE
8 S GMRG2=GMRG1,GMRG3=$S(GMRG2="":0,GMRGTX(0)[GMRG2:1,1:0) W:'GMRG3 $C(7)," ??",!
9 I GMRG3 D WITH Q:GMRGTX(0)=""!GMRGOUT W ! G REPLACE
10 W ! G REPLACE
11REPHLP 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"
12 W !?5,"from ""(text)"" through the end.",!?5,"At the ""With"" prompt, enter the new text.",!?10
13 Q
14WITH W " With " R GMRG4:DTIME S:GMRG4="^"!(GMRG4="^^")!'$T GMRGOUT=1 Q:GMRGOUT I GMRG4?1"?".E D REPHLP G WITH
15 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
16 Q:GMRGOUT S GMRGTX(0)=GMRGTX(2)
17 Q
18RANGE S GMRG5=$P(GMRG1,"..."),GMRG7=$F(GMRGTX(0),GMRG5),GMRG5(0)=$S(GMRG5'=""&GMRG7:GMRG7-$L(GMRG5),'GMRG7:0,1:1)
19 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))
20 Q
21DEL ; DELETE EXISTING TEXT
22 I 'GMRGTX("@") W !,$C(7),"CANNOT DELETE!!" Q
23 I GMRGTX(1) W !?5,$C(7),"If you delete bracketed text, the original default will become the",!?5,"the new value."
24 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
25 Q
26VALIDATE ; VALIDATE USER SELECTION ENTRY
27 F GMRG1=1:1 S GMRG2=$P(GMRGS,",",GMRG1) Q:GMRG2="" S:GMRG2="a" GMRG2="A" D VAL0 Q:'GMRGOOD
28 Q
29VAL0 ; VALIDATION CONT.
30 I GMRG2["-" S GMRG3=$P(GMRG2,"-"),GMRG2=$P(GMRG2,"-",2),GMRG5=1 S:GMRG2="a" GMRG2="A"
31 E S GMRG3=$S(GMRG2'="A":+GMRG2,1:GMRG2),GMRG5=0
32 I '(GMRG3?1N.N!('GMRG5&(GMRG3="A"))!(GMRG3>0)) S GMRGOOD=0 Q
33 I GMRG5,GMRG2="A" S GMRGOOD=0 Q
34 S:GMRG2?1N.N1"/;" GMRG2=+GMRG2_";/"
35 I GMRG2?1N.N!(GMRG2?1N.N1"@")!(GMRG2?1N.N1";")!(GMRG2?1N.N1"/")!(GMRG2?1N.N1"/;")!(GMRG2?1N.N1";/")!(GMRG2="A") D VAL1 Q
36 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
37 S GMRGOOD=0
38 Q
39VAL1 ;
40 I GMRG2="A" S GMRGQUSL("A")=1 Q
41 I +GMRG2<1!(+GMRG2>GMRGSTAR(1))!(+GMRG2<GMRG3)!(GMRG3<1)!(GMRG3>GMRGSTAR(1)) S GMRGOOD=0 Q
42 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))
43 Q
44VALTXT ;
45 I +GMRG2<1!(+GMRG2>GMRGSTAR(1)) S GMRGOOD=0 Q
46 K GMRG4 S (GMRG12,GMRG13,GMRG11)=0,GMRG14=$L($P(GMRGSEL(+GMRG2),"^",2),"]")-1
47 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
48 S GMRG11=0
49 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
50 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
51 I GMRG12>175 S GMRGOOD=0 Q
52 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))
53 S GMRGQUSL(+GMRG2)=$P(GMRG2,+GMRG2,2,$L(GMRG2,+GMRG2))
54 Q
55STXT ;
56 S:GMRG12>0 GMRG11=1 S:GMRG13>0 GMRG14=GMRG14-1
57 S:GMRG13>0 GMRG4(GMRG13-1)="I"
58 S:GMRG12>0 GMRG4(GMRG12-1)="A"
59 Q
60STXT1 ;
61 S:GMRG4(GMRG6)="I" GMRG11=GMRG11+1,GMRG4("I",GMRG11)=$E(GMRG2,GMRG6,GMRG13)
62 S:GMRG4(GMRG6)="A" GMRG4("A")=$E(GMRG2,GMRG6,GMRG13)
63 Q
64PROMPT ;
65 I $P(GMRGTERM(0),"^",6)=""&($P(GMRGTERM(0),"^",7)="") W "Select: " Q
66 I $P(GMRGTERM(0),"^",7)="" W "Select at least ",$P(GMRGTERM(0),"^",6),": " Q
67 I $P(GMRGTERM(0),"^",6)="" W "Select up to ",$P(GMRGTERM(0),"^",7),": " Q
68 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),": "
69 E W "Select only ",$P(GMRGTERM(0),"^",6),": "
70 Q
Note: See TracBrowser for help on using the repository browser.