- GMRGED9 ;CISC/JH/RM-PATIENT DATA EDIT (cont.) ;4/5/90
- ;;3.0;Text Generator;;Jan 24, 1996
- EN1 ; PRINT TEXT ON TOP
- D:'$D(^TMP($J,"GMRGNAR","TOP")) EN2
- 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
- K I,J,L,X,GMRLINS Q
- DISP W !,^TMP($J,"GMRGNAR","TOP",I,L) S GMRGLIN=GMRGLIN+1 D INQ:GMRGLIN>(IOSL-5)!(L=GMRLINS) Q
- ;
- INQ 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
- ;
- EN2 ; SET TEXT ON TOP ARRAY, GMRGTOP(0)=TERM TO BEGIN BUILDING TEXT FROM
- K ^TMP($J,"GMRGNAR") D NOW^%DTC S GMRGPDT=%,GMRGPAR=GMRGTOP(0),GMRGPAR(0)="1^0^0^"_"TOP" D EN1^GMRGPNBL
- K %,GMRGPDT,GMRGPAR
- Q
- JSTCK ; MANIPULATE GMRGLVL STACK FOR JUMPING AND SCRIPING
- S $P(GMRGLVL($P(GMRGLVL,"^"),GMRGTLVL),"^")=GMRG2,^TMP($J,"GMRGLVL",$P(GMRGLVL,"^"),GMRGTLVL,GMRG2)=GMRG0_"^^11",GMRG0(1)=0,GMRGSLVL=GMRG2
- I GMRGUSL(GMRG0)'="" F GMRG0(0)=1:1:$L(GMRGUSL(GMRG0),"^") D PSTCK
- S ^TMP($J,$P(GMRGLVL,"^"),GMRGTLVL,GMRGSLVL)=+GMRG0_"^^0",$P(GMRGLVL,"^")=$P(GMRGLVL,"^")-1,GMRGTLVL=$P(GMRGLVL(+GMRGLVL),"^")
- Q
- PSTCK ;
- I 'GMRG0(1) S GMRG0(1)=1,$P(GMRGLVL,"^")=+GMRGLVL+1,GMRGLVL(+GMRGLVL)=1_"^"_GMRGTLVL,GMRGTLVL=1,GMRGLVL(+GMRGLVL,1)=1_"^"_GMRGSLVL,GMRGSLVL=1
- E S GMRGTLVL=GMRGTLVL+1,$P(GMRGLVL($P(GMRGLVL,"^")),"^")=GMRGTLVL,$P(GMRGLVL($P(GMRGLVL,"^"),GMRGTLVL),"^")=1
- S Y=+$P(GMRGUSL(GMRG0),"^",GMRG0(0)),GMRGKU=$O(^GMR(124.3,GMRGPDA,1,"B",Y,0))
- 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")
- 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:"")
- S ^TMP($J,"GMRGLVL",$P(GMRGLVL,"^"),GMRGTLVL,GMRGSLVL)=GMRGPRC,^(GMRGSLVL,0)=GMRGPRC(0)
- Q:+GMRG0=+GMRGPRC I GMRGKU'>0 S GMRGSTAT="^^"
- E S GMRGST=GMRGKU,GMRGST(1)=GMRGPDA D STAT^GMRGRUT0
- I +GMRGRT=+GMRGTERM S GMRGSTAT="^^1"
- I '$P(GMRGSTAT,"^",3) D ADSEL^GMRGEDB
- Q
- SCRPT ; PROCESS SCRIPT FOR A TERM
- 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
- I '$D(^GMR(124.3,GMRGPDA,1,"ALIST",$P(GMRGPRC,"^"))),$P(GMRGPRC(0),"^")["]",$P(GMRGPRC,"^",2)'["/" S $P(GMRGPRC,"^",2)=$P(GMRGPRC,"^",2)_"/"
- S GMRGKU=$O(^GMR(124.3,GMRGPDA,1,"B",+GMRGTERM,0)) I GMRGKU'>0 S GMRGSTAT="^^"
- E S GMRGST=GMRGKU,GMRGST(1)=GMRGPDA D STAT^GMRGRUT0
- I +GMRGRT=+GMRGTERM S GMRGSTAT="^^1"
- I '$P(GMRGSTAT,"^",3) D ADSEL^GMRGEDB
- 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"
- 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)
- S Y=0 F Z=1:1:$L(GMRGTX("OL"),"|") I $P(GMRGTX("OL"),"|",Z)'="" S Y=1 Q
- S:'Y GMRGTX("OL")=""
- S Y=0 F Z=1:1:$L(GMRGTX,"|") I $P(GMRGTX,"|",Z)'="" S Y=1 Q
- I 'Y S:$L(GMRGTX) $P(GMRGPRC,"^",2)=$P(GMRGPRC,"^",2)_$S($P(GMRGPRC,"^",2)'?.E1"/":"/",1:"") S GMRGTX=""
- I GMRGTX("OL")="",GMRGTX'="" D SAT^GMRGED5
- I $P(GMRGPRC,"^",2)?0.1AP1"/".E,GMRGTX="" D INTERNAL^GMRGED6 Q:GMRGOUT
- 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:"")
- 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
- X:$D(^GMRD(124.2,+GMRGTERM,7)) ^(7) Q:GMRGOUT D HDR^GMRGEDB Q:GMRGOUT
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRGED9 3782 printed Feb 18, 2025@23:21:44 Page 2
- GMRGED9 ;CISC/JH/RM-PATIENT DATA EDIT (cont.) ;4/5/90
- +1 ;;3.0;Text Generator;;Jan 24, 1996
- EN1 ; PRINT TEXT ON TOP
- +1 if '$DATA(^TMP($JOB,"GMRGNAR","TOP"))
- DO EN2
- +2 SET (X,GMRGLIN)=0
- SET I=$ORDER(^TMP($JOB,"GMRGNAR","TOP",0))
- SET GMRLINS=$PIECE(^(I,0),"^",2)
- SET L=1
- if GMRLINS>1
- WRITE @IOF,^TMP($JOB,"GMRGNAR","TOP",I,1)
- FOR L=2:1:GMRLINS
- SET J=$ORDER(^TMP($JOB,"GMRGNAR","TOP",I,L))
- if L=""
- QUIT
- DO DISP
- if X="^"!GMRGOUT
- QUIT
- +3 KILL I,J,L,X,GMRLINS
- QUIT
- DISP WRITE !,^TMP($JOB,"GMRGNAR","TOP",I,L)
- SET GMRGLIN=GMRGLIN+1
- if GMRGLIN>(IOSL-5)!(L=GMRLINS)
- DO INQ
- QUIT
- +1 ;
- INQ WRITE !!,"Press return to continue, or ^ to stop narrative listing. "
- READ X:DTIME
- if X="^^"!'$TEST
- SET GMRGOUT=1
- IF 'GMRGOUT!(X="^")
- SET GMRGLIN=0
- WRITE @IOF
- QUIT
- +1 ;
- EN2 ; SET TEXT ON TOP ARRAY, GMRGTOP(0)=TERM TO BEGIN BUILDING TEXT FROM
- +1 KILL ^TMP($JOB,"GMRGNAR")
- DO NOW^%DTC
- SET GMRGPDT=%
- SET GMRGPAR=GMRGTOP(0)
- SET GMRGPAR(0)="1^0^0^"_"TOP"
- DO EN1^GMRGPNBL
- +2 KILL %,GMRGPDT,GMRGPAR
- +3 QUIT
- JSTCK ; MANIPULATE GMRGLVL STACK FOR JUMPING AND SCRIPING
- +1 SET $PIECE(GMRGLVL($PIECE(GMRGLVL,"^"),GMRGTLVL),"^")=GMRG2
- SET ^TMP($JOB,"GMRGLVL",$PIECE(GMRGLVL,"^"),GMRGTLVL,GMRG2)=GMRG0_"^^11"
- SET GMRG0(1)=0
- SET GMRGSLVL=GMRG2
- +2 IF GMRGUSL(GMRG0)'=""
- FOR GMRG0(0)=1:1:$LENGTH(GMRGUSL(GMRG0),"^")
- DO PSTCK
- +3 SET ^TMP($JOB,$PIECE(GMRGLVL,"^"),GMRGTLVL,GMRGSLVL)=+GMRG0_"^^0"
- SET $PIECE(GMRGLVL,"^")=$PIECE(GMRGLVL,"^")-1
- SET GMRGTLVL=$PIECE(GMRGLVL(+GMRGLVL),"^")
- +4 QUIT
- PSTCK ;
- +1 IF 'GMRG0(1)
- SET GMRG0(1)=1
- SET $PIECE(GMRGLVL,"^")=+GMRGLVL+1
- SET GMRGLVL(+GMRGLVL)=1_"^"_GMRGTLVL
- SET GMRGTLVL=1
- SET GMRGLVL(+GMRGLVL,1)=1_"^"_GMRGSLVL
- SET GMRGSLVL=1
- +2 IF '$TEST
- SET GMRGTLVL=GMRGTLVL+1
- SET $PIECE(GMRGLVL($PIECE(GMRGLVL,"^")),"^")=GMRGTLVL
- SET $PIECE(GMRGLVL($PIECE(GMRGLVL,"^"),GMRGTLVL),"^")=1
- +3 SET Y=+$PIECE(GMRGUSL(GMRG0),"^",GMRG0(0))
- SET GMRGKU=$ORDER(^GMR(124.3,GMRGPDA,1,"B",Y,0))
- +4 SET GMRGPRC=Y_"^"_$SELECT(GMRG0["T":"S^11",GMRG0(0)<($LENGTH(GMRGUSL(GMRG0),"^")-1):"J^11",1:$SELECT(GMRG0(0)=$LENGTH(GMRGUSL(GMRG0),"^"):"^",1:"J^1")_"0")
- +5 SET GMRGPRC(0)=$SELECT($DATA(^GMRD(124.2,Y,0)):$PIECE(^(0),"^"),1:"")_"^"_GMRGKU_"^"_$SELECT($DATA(^GMR(124.3,GMRGPDA,1,+GMRGKU,0)):$PIECE(^(0),"^",2),1:"")
- +6 SET ^TMP($JOB,"GMRGLVL",$PIECE(GMRGLVL,"^"),GMRGTLVL,GMRGSLVL)=GMRGPRC
- SET ^(GMRGSLVL,0)=GMRGPRC(0)
- +7 if +GMRG0=+GMRGPRC
- QUIT
- IF GMRGKU'>0
- SET GMRGSTAT="^^"
- +8 IF '$TEST
- SET GMRGST=GMRGKU
- SET GMRGST(1)=GMRGPDA
- DO STAT^GMRGRUT0
- +9 IF +GMRGRT=+GMRGTERM
- SET GMRGSTAT="^^1"
- +10 IF '$PIECE(GMRGSTAT,"^",3)
- DO ADSEL^GMRGEDB
- +11 QUIT
- SCRPT ; PROCESS SCRIPT FOR A TERM
- +1 SET GMRGTERM=$PIECE(GMRGPRC,"^")_"^"_$PIECE(GMRGPRC(0),"^",1,2)
- SET GMRGTERM(0)=$SELECT($DATA(^GMRD(124.2,+GMRGTERM,0)):^(0),1:"")
- KILL GMRGUSL
- DO SETSEL^GMRGED4
- +2 IF '$DATA(^GMR(124.3,GMRGPDA,1,"ALIST",$PIECE(GMRGPRC,"^")))
- IF $PIECE(GMRGPRC(0),"^")["]"
- IF $PIECE(GMRGPRC,"^",2)'["/"
- SET $PIECE(GMRGPRC,"^",2)=$PIECE(GMRGPRC,"^",2)_"/"
- +3 SET GMRGKU=$ORDER(^GMR(124.3,GMRGPDA,1,"B",+GMRGTERM,0))
- IF GMRGKU'>0
- SET GMRGSTAT="^^"
- +4 IF '$TEST
- SET GMRGST=GMRGKU
- SET GMRGST(1)=GMRGPDA
- DO STAT^GMRGRUT0
- +5 IF +GMRGRT=+GMRGTERM
- SET GMRGSTAT="^^1"
- +6 IF '$PIECE(GMRGSTAT,"^",3)
- DO ADSEL^GMRGEDB
- +7 FOR Z=0:0
- SET Z=$ORDER(GMRGSEL(Z))
- if Z'>0
- QUIT
- IF $DATA(^GMRD(124.4,GMRGTPLT,1,"B",+GMRGSEL(Z)))
- SET Y=$ORDER(^GMRD(124.4,GMRGTPLT,1,"B",+GMRGSEL(Z),0))
- SET GMRGUSL(Z)="S"
- +8 SET GMRGKU=$ORDER(^GMRD(124.4,GMRGTPLT,1,"B",+GMRGTERM,0))
- if GMRGKU'>0
- QUIT
- SET GMRGTX=$SELECT($DATA(^GMRD(124.4,GMRGTPLT,1,GMRGKU,0)):$PIECE(^(0),"^",2),1:"")
- SET GMRGTX("OL")=$PIECE(GMRGPRC(0),"^",3)
- +9 SET Y=0
- FOR Z=1:1:$LENGTH(GMRGTX("OL"),"|")
- IF $PIECE(GMRGTX("OL"),"|",Z)'=""
- SET Y=1
- QUIT
- +10 if 'Y
- SET GMRGTX("OL")=""
- +11 SET Y=0
- FOR Z=1:1:$LENGTH(GMRGTX,"|")
- IF $PIECE(GMRGTX,"|",Z)'=""
- SET Y=1
- QUIT
- +12 IF 'Y
- if $LENGTH(GMRGTX)
- SET $PIECE(GMRGPRC,"^",2)=$PIECE(GMRGPRC,"^",2)_$SELECT($PIECE(GMRGPRC,"^",2)'?.E1"/":"/",1:"")
- SET GMRGTX=""
- +13 IF GMRGTX("OL")=""
- IF GMRGTX'=""
- DO SAT^GMRGED5
- +14 IF $PIECE(GMRGPRC,"^",2)?0.1AP1"/".E
- IF GMRGTX=""
- DO INTERNAL^GMRGED6
- if GMRGOUT
- QUIT
- +15 SET GMRGTX=$SELECT($DATA(^GMRD(124.4,GMRGTPLT,1,GMRGKU,"ADD")):^("ADD"),1:"")
- SET GMRGTX("OL")=$SELECT($DATA(^GMR(124.3,GMRGPDA,1,+$PIECE(GMRGPRC(0),"^",2),"ADD")):^("ADD"),1:"")
- +16 IF GMRGTX("OL")=""
- IF GMRGTX'=""
- SET GMRGUSL("A")=""
- SET X=GMRGTX("OL")
- SET DA=$PIECE(GMRGPRC(0),"^",2)
- SET DA(1)=GMRGPDA
- SET GMRGY=2
- SET GMRGAT=1
- SET GMRGZ=""
- DO EN1^GMRGUTL
- SET ^GMR(124.3,DA(1),1,DA,"ADD")=GMRGTX
- +17 if $DATA(^GMRD(124.2,+GMRGTERM,7))
- XECUTE ^(7)
- if GMRGOUT
- QUIT
- DO HDR^GMRGEDB
- if GMRGOUT
- QUIT
- +18 QUIT
