source: WorldVistAEHR/trunk/r/GEN_MED_REC_GENERATOR-GMRG/GMRGED9.m@ 623

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

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1GMRGED9 ;CISC/JH/RM-PATIENT DATA EDIT (cont.) ;4/5/90
2 ;;3.0;Text Generator;;Jan 24, 1996
3EN1 ; PRINT TEXT ON TOP
4 D:'$D(^TMP($J,"GMRGNAR","TOP")) EN2
5 S (X,GMRGLIN)=0,I=$O(^TMP($J,"GMRGNAR","TOP",0)),GMRLINS=$P(^(I,0),"^",2),L=1 W:GMRLINS>1 @IOF,^TMP($J,"GMRGNAR","TOP",I,1) F L=2:1:GMRLINS S J=$O(^TMP($J,"GMRGNAR","TOP",I,L)) Q:L="" D DISP Q:X="^"!GMRGOUT
6 K I,J,L,X,GMRLINS Q
7DISP W !,^TMP($J,"GMRGNAR","TOP",I,L) S GMRGLIN=GMRGLIN+1 D INQ:GMRGLIN>(IOSL-5)!(L=GMRLINS) Q
8 ;
9INQ W !!,"Press return to continue, or ^ to stop narrative listing. " R X:DTIME S:X="^^"!'$T GMRGOUT=1 I 'GMRGOUT!(X="^") S GMRGLIN=0 W @IOF Q
10 ;
11EN2 ; SET TEXT ON TOP ARRAY, GMRGTOP(0)=TERM TO BEGIN BUILDING TEXT FROM
12 K ^TMP($J,"GMRGNAR") D NOW^%DTC S GMRGPDT=%,GMRGPAR=GMRGTOP(0),GMRGPAR(0)="1^0^0^"_"TOP" D EN1^GMRGPNBL
13 K %,GMRGPDT,GMRGPAR
14 Q
15JSTCK ; MANIPULATE GMRGLVL STACK FOR JUMPING AND SCRIPING
16 S $P(GMRGLVL($P(GMRGLVL,"^"),GMRGTLVL),"^")=GMRG2,^TMP($J,"GMRGLVL",$P(GMRGLVL,"^"),GMRGTLVL,GMRG2)=GMRG0_"^^11",GMRG0(1)=0,GMRGSLVL=GMRG2
17 I GMRGUSL(GMRG0)'="" F GMRG0(0)=1:1:$L(GMRGUSL(GMRG0),"^") D PSTCK
18 S ^TMP($J,$P(GMRGLVL,"^"),GMRGTLVL,GMRGSLVL)=+GMRG0_"^^0",$P(GMRGLVL,"^")=$P(GMRGLVL,"^")-1,GMRGTLVL=$P(GMRGLVL(+GMRGLVL),"^")
19 Q
20PSTCK ;
21 I 'GMRG0(1) S GMRG0(1)=1,$P(GMRGLVL,"^")=+GMRGLVL+1,GMRGLVL(+GMRGLVL)=1_"^"_GMRGTLVL,GMRGTLVL=1,GMRGLVL(+GMRGLVL,1)=1_"^"_GMRGSLVL,GMRGSLVL=1
22 E S GMRGTLVL=GMRGTLVL+1,$P(GMRGLVL($P(GMRGLVL,"^")),"^")=GMRGTLVL,$P(GMRGLVL($P(GMRGLVL,"^"),GMRGTLVL),"^")=1
23 S Y=+$P(GMRGUSL(GMRG0),"^",GMRG0(0)),GMRGKU=$O(^GMR(124.3,GMRGPDA,1,"B",Y,0))
24 S GMRGPRC=Y_"^"_$S(GMRG0["T":"S^11",GMRG0(0)<($L(GMRGUSL(GMRG0),"^")-1):"J^11",1:$S(GMRG0(0)=$L(GMRGUSL(GMRG0),"^"):"^",1:"J^1")_"0")
25 S GMRGPRC(0)=$S($D(^GMRD(124.2,Y,0)):$P(^(0),"^"),1:"")_"^"_GMRGKU_"^"_$S($D(^GMR(124.3,GMRGPDA,1,+GMRGKU,0)):$P(^(0),"^",2),1:"")
26 S ^TMP($J,"GMRGLVL",$P(GMRGLVL,"^"),GMRGTLVL,GMRGSLVL)=GMRGPRC,^(GMRGSLVL,0)=GMRGPRC(0)
27 Q:+GMRG0=+GMRGPRC I GMRGKU'>0 S GMRGSTAT="^^"
28 E S GMRGST=GMRGKU,GMRGST(1)=GMRGPDA D STAT^GMRGRUT0
29 I +GMRGRT=+GMRGTERM S GMRGSTAT="^^1"
30 I '$P(GMRGSTAT,"^",3) D ADSEL^GMRGEDB
31 Q
32SCRPT ; PROCESS SCRIPT FOR A TERM
33 S GMRGTERM=$P(GMRGPRC,"^")_"^"_$P(GMRGPRC(0),"^",1,2),GMRGTERM(0)=$S($D(^GMRD(124.2,+GMRGTERM,0)):^(0),1:"") K GMRGUSL D SETSEL^GMRGED4
34 I '$D(^GMR(124.3,GMRGPDA,1,"ALIST",$P(GMRGPRC,"^"))),$P(GMRGPRC(0),"^")["]",$P(GMRGPRC,"^",2)'["/" S $P(GMRGPRC,"^",2)=$P(GMRGPRC,"^",2)_"/"
35 S GMRGKU=$O(^GMR(124.3,GMRGPDA,1,"B",+GMRGTERM,0)) I GMRGKU'>0 S GMRGSTAT="^^"
36 E S GMRGST=GMRGKU,GMRGST(1)=GMRGPDA D STAT^GMRGRUT0
37 I +GMRGRT=+GMRGTERM S GMRGSTAT="^^1"
38 I '$P(GMRGSTAT,"^",3) D ADSEL^GMRGEDB
39 F Z=0:0 S Z=$O(GMRGSEL(Z)) Q:Z'>0 I $D(^GMRD(124.4,GMRGTPLT,1,"B",+GMRGSEL(Z))) S Y=$O(^GMRD(124.4,GMRGTPLT,1,"B",+GMRGSEL(Z),0)),GMRGUSL(Z)="S"
40 S GMRGKU=$O(^GMRD(124.4,GMRGTPLT,1,"B",+GMRGTERM,0)) Q:GMRGKU'>0 S GMRGTX=$S($D(^GMRD(124.4,GMRGTPLT,1,GMRGKU,0)):$P(^(0),"^",2),1:""),GMRGTX("OL")=$P(GMRGPRC(0),"^",3)
41 S Y=0 F Z=1:1:$L(GMRGTX("OL"),"|") I $P(GMRGTX("OL"),"|",Z)'="" S Y=1 Q
42 S:'Y GMRGTX("OL")=""
43 S Y=0 F Z=1:1:$L(GMRGTX,"|") I $P(GMRGTX,"|",Z)'="" S Y=1 Q
44 I 'Y S:$L(GMRGTX) $P(GMRGPRC,"^",2)=$P(GMRGPRC,"^",2)_$S($P(GMRGPRC,"^",2)'?.E1"/":"/",1:"") S GMRGTX=""
45 I GMRGTX("OL")="",GMRGTX'="" D SAT^GMRGED5
46 I $P(GMRGPRC,"^",2)?0.1AP1"/".E,GMRGTX="" D INTERNAL^GMRGED6 Q:GMRGOUT
47 S GMRGTX=$S($D(^GMRD(124.4,GMRGTPLT,1,GMRGKU,"ADD")):^("ADD"),1:""),GMRGTX("OL")=$S($D(^GMR(124.3,GMRGPDA,1,+$P(GMRGPRC(0),"^",2),"ADD")):^("ADD"),1:"")
48 I GMRGTX("OL")="",GMRGTX'="" S GMRGUSL("A")="",X=GMRGTX("OL"),DA=$P(GMRGPRC(0),"^",2),DA(1)=GMRGPDA,GMRGY=2,GMRGAT=1,GMRGZ="" D EN1^GMRGUTL S ^GMR(124.3,DA(1),1,DA,"ADD")=GMRGTX
49 X:$D(^GMRD(124.2,+GMRGTERM,7)) ^(7) Q:GMRGOUT D HDR^GMRGEDB Q:GMRGOUT
50 Q
Note: See TracBrowser for help on using the repository browser.