source: WorldVistAEHR/trunk/r/GEN_MED_REC_GENERATOR-GMRG/GMRGED6.m@ 1259

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

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1GMRGED6 ;CISC/RM-PATIENT DATA EDIT (cont.) ;4/25/89
2 ;;3.0;Text Generator;;Jan 24, 1996
3INTERNAL ; EDIT INTERNAL TEXT FOR THE SELECTED ENTRY.
4 S (GMRGTX("OL"),GMRGTX)=$P(GMRGPRC(0),"^",3),GMRGTX("ACTION")=$P($P(GMRGPRC,"^",2),"/",2,999)
5 I GMRGTX("ACTION")="" D INTP
6 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))
7 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
8 I 'GMRGOUT,GMRGTX("OL")'=GMRGTX S ^TMP($J,"GMRGLVL",$P(GMRGLVL,"^"),GMRGTLVL,GMRGSLVL,0)=GMRGPRC(0)
9 Q
10INTP ;
11 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 "'"
12 F GMRG10=1:1:$L($P(GMRGPRC(0),"^"),"]")-1 D INTXED Q:GMRGOUT S $P(GMRGTX,"|",GMRG10+1)=GMRGTX(0)
13 Q
14INTXED ;
15 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")))
16 S (GMRGTX("OLD"),GMRGTX(0))=$S($P(GMRGTX,"|",GMRG10+1)="":GMRGTX("DEF"),1:$P(GMRGTX,"|",GMRG10+1))
17INTX0 ;
18 I $L(GMRGTX(0))>15 S (GMRGTX("@"),GMRGTX(1))=1 W ! D EN1^GMRGED3 S:GMRGTX(0)="" GMRGTX(0)=GMRGTX("DEF") G INTX1
19 W !,"Internal Text Number ",GMRG10,": ",$S($L(GMRGTX(0)):GMRGTX(0)_"// ",1:"") R GMRGTX(0):DTIME
20 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
21YNIP 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))
22 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
23INTX1 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
24 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
25 Q
26DELETE ;
27 S GMRGDFLG=1,X=$P(GMRGPRC,"^"),DA(1)=GMRGPDA,DA=$P(GMRGPRC(0),"^",2) I DA'>0 K DA Q
28 S GMRGY=0 D EN1^GMRGUTL
29 K GMRGDFLG S GMRGART=0 X:$D(^GMRD(124.2,$P(GMRGPRC,"^"),8)) ^(8) Q:GMRGOUT
30 Q
31STUT ;
32 I GMRG0["*"!(GMRG0["T") D JSTCK^GMRGED9 Q
33 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)
34 S ^TMP($J,"GMRGLVL",$P(GMRGLVL,"^"),GMRGTLVL,GMRG2)=$S(GMRG0'="A":$P(GMRGSEL(GMRG0),"^")_"^"_GMRGUSL(GMRG0),1:"A^"_GMRGTERM)_"^"_GMRG3
35 S:GMRG0'="A" ^TMP($J,"GMRGLVL",$P(GMRGLVL,"^"),GMRGTLVL,GMRG2,0)=$P(GMRGSEL(GMRG0),"^",2)_"^"_$S($D(GMRGSEL(GMRG0,1)):GMRGSEL(GMRG0,1),1:"")
36 Q
37PRCTRM ;
38 Q:+GMRGTERM=+GMRGRT K DA S DA(1)=GMRGPDA,DA=$P(GMRGTERM,"^",3)
39 S GMRGND=GMRGPDA,GMRGND(0)=$P(GMRGTERM,"^") D STLST^GMRGRUT0
40 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
41 I '$P(^GMR(124.3,DA(1),1,DA,0),"^",3) D ADS
42 Q
43ADS ;
44 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)
45 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)
46 S GMRGART=1 X:$D(^GMRD(124.2,$P(GMRGTERM,"^"),8)) ^(8)
47 Q
Note: See TracBrowser for help on using the repository browser.