- GMRGUT1 ;HIRMFO/DDA,RM-UTILITIES ROUTINE FOR GMRG FILES (CONT.) ;9/1/95
- ;;3.0;Text Generator;;Jan 24, 1996
- EN3 ; ENTRY TO UPDATE NODE ID FIELD
- S GMRG=$S($D(^GMRD(124.2,DA,0)):^(0),1:""),GMRG(1)=$P(GMRG,"^"),GMRG(2)=$P(GMRG,"^",2),GMRG(3)=$P(GMRG,"^",3),GMRG(5)=$P(GMRG,"^",5) G Q3:GMRG(1)=""!(GMRG(2)="")!(GMRG(3)="") S GMRG("X")=X
- I GMRG(5)'="" S GMRG("QT")=0 F GMRG("DA")=0:0 S GMRG("DA")=$O(^GMRD(124.2,"AA",GMRG(3),GMRG(2),GMRG(1),GMRG(5),GMRG("DA"))) Q:GMRG("DA")'>0 I GMRG("DA")'=DA S GMRG("QT")=1 Q
- I GMRG(5)'="",'GMRG("QT") S GMRG("NODE")=GMRG(5) G S3
- S GMRG("QT")=0 F GMRG("NODE")=1:1 Q:$D(^GMRD(124.2,"AA",GMRG(3),GMRG(2),GMRG(1),GMRG("NODE"),DA)) I '$D(^GMRD(124.2,"AA",GMRG(3),GMRG(2),GMRG(1),GMRG("NODE"))) D:GMRG(5)'="" CLND Q:GMRG(5)=""!(GMRG(5)'=""&GMRG("QT"))
- I GMRG(5)'="" S X=GMRG(5) F GMRG("L")=0:0 S GMRG("L")=$O(^DD(124.2,.05,1,GMRG("L"))) Q:GMRG("L")'>0 X:$D(^DD(124.2,.05,1,GMRG("L"),2)) ^(2)
- S3 S X=GMRG("NODE"),$P(^GMRD(124.2,DA,0),"^",5)=X F GMRG("L")=0:0 S GMRG("L")=$O(^DD(124.2,.05,1,GMRG("L"))) Q:GMRG("L")'>0 X:$D(^DD(124.2,.05,1,GMRG("L"),1)) ^(1)
- S X=GMRG("X")
- Q3 K GMRG
- Q
- CLND ;
- S GMRG("QT")=1 F GMRG("DA")=0:0 S GMRG("DA")=$O(^GMRD(124.2,"AA",GMRG(3),GMRG(2),GMRG(1),GMRG("NODE"),GMRG("DA"))) Q:GMRG("DA")'>0 I GMRG("DA")'=DA S GMRG("QT")=0 Q
- Q
- EN4 ; SCREEN FROM THE TYPE OF TERM (#.02) FIELD FROM AGGREGRATE TERM FILE
- S GMRG("L")=2,GMRG("H")=4
- S GMRG=$O(^GMRD(124.2,DA,1,"AC",0)) S:GMRG'="" GMRG("H")=2
- I Y'<GMRG("L"),Y'>GMRG("H")
- K GMRG
- Q
- EN5 ; ENTRY TO SET LIST XREF OF THE SELECTION SUBFIELD (#.01) OF THE
- ; SELECTION FIELD (#1) OF THE GMR TEXT (#124.3) FILE
- S GMRG(1)=$S($D(^GMR(124.3,DA(2),1,DA(1),0)):$P(^(0),U),1:"") Q:GMRG(1)'>0 S:'$D(^GMR(124.3,DA(2),1,"ALIST",GMRG(1),1)) ^(1)="^0"
- S GMRGND=DA(2),GMRGND(0)=GMRG(1) D STLST^GMRGRUT0
- Q
- EN6 ; ENTRY TO KILL LIST XREF OF THE SELECTION SUBFIELD (#.01) OF THE
- ; SELECTION FIELD (#1) OF THE GMR TEXT (#124.3) FILE
- S GMRG(1)=$S($D(^GMR(124.3,DA(2),1,DA(1),0)):$P(^(0),U),1:"") Q:GMRG(1)'>0 F GMRG=0:0 S GMRG=$O(^GMR(124.3,DA(2),1,"ALIST",GMRG(1),GMRG)) Q:GMRG'>0 K ^GMR(124.3,DA(2),1,"ALIST",GMRG(1),GMRG)
- S GMRGND=DA(2),GMRGND(0)=GMRG(1) D DLLST^GMRGRUT0
- Q
- EN7 ; ENTRY TO UPDATE ALIST XREF
- I '$D(GMRGRT) F GMRG(1)=0:0 S GMRG(1)=$O(^GMR(124.3,DA(2),1,DA(1),2,GMRG(1))) Q:GMRG(1)'>0 I $D(^GMR(124.3,DA(2),1,DA(1),2,GMRG(1),0)),$P(^(0),"^"),$S(GMRG:1,GMRG(1)=DA:0,1:1) S GMRG(1,(9999999-$P(^(0),"^")))=$P(^(0),"^",2)
- S GMRG(1)=$S($D(GMRGRT):$O(^GMR(124.3,DA(2),1,DA(1),2,"AA",0)),1:$O(GMRG(1,0))),GMRG(2)=$S($D(GMRGRT):$O(^GMR(124.3,DA(2),1,DA(1),2,"AA",+GMRG(1),0)),$D(GMRG(1,+GMRG(1))):GMRG(1,GMRG(1)),1:0)
- K GMRG(1) I '$D(GMRGRT),GMRG(2) D STPAR
- D EN5:GMRG(2),EN6:'GMRG(2) K GMRG
- Q
- STPAR ;
- S GMRG(1,0)=$S($D(^GMR(124.3,DA(2),1,DA(1),0)):+$P(^(0),"^"),1:0) Q:'GMRG(1,0) S:$S('$D(^GMR(124.3,DA(2),0)):0,'$D(^GMRD(124.2,"AKID",GMRG(1,0),+^GMR(124.3,DA(2),0))):0,1:1) GMRG(0,+^GMR(124.3,DA(2),0))=""
- F GMRG(1)=0:0 S GMRG(1)=$O(^GMR(124.3,DA(2),1,GMRG(1))) Q:GMRG(1)'>0 I $D(^GMR(124.3,DA(2),1,GMRG(1),0)),$D(^GMRD(124.2,"AKID",GMRG(1,0),+^GMR(124.3,DA(2),1,GMRG(1),0))) D STPAR1
- Q
- STPAR1 ;
- K GMRG("A") F GMRG(0)=0:0 S GMRG(0)=$O(^GMR(124.3,DA(2),1,GMRG(1),2,GMRG(0))) Q:GMRG(0)'>0 S GMRG(3)=$S($D(^GMR(124.3,DA(2),1,GMRG(1),2,GMRG(0),0)):^(0),1:"") I +GMRG(3) S GMRG("A",9999999-GMRG(3))=GMRG(3)
- S GMRG(0)=$O(GMRG("A",0)) S:$S('$D(GMRG("A",+GMRG(0))):0,$P(GMRG("A",+GMRG(0)),"^",2):1,1:0) GMRG(0,+^GMR(124.3,DA(2),1,GMRG(1),0))=""
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRGUT1 3510 printed Jan 18, 2025@02:56:55 Page 2
- GMRGUT1 ;HIRMFO/DDA,RM-UTILITIES ROUTINE FOR GMRG FILES (CONT.) ;9/1/95
- +1 ;;3.0;Text Generator;;Jan 24, 1996
- EN3 ; ENTRY TO UPDATE NODE ID FIELD
- +1 SET GMRG=$SELECT($DATA(^GMRD(124.2,DA,0)):^(0),1:"")
- SET GMRG(1)=$PIECE(GMRG,"^")
- SET GMRG(2)=$PIECE(GMRG,"^",2)
- SET GMRG(3)=$PIECE(GMRG,"^",3)
- SET GMRG(5)=$PIECE(GMRG,"^",5)
- if GMRG(1)=""!(GMRG(2)="")!(GMRG(3)="")
- GOTO Q3
- SET GMRG("X")=X
- +2 IF GMRG(5)'=""
- SET GMRG("QT")=0
- FOR GMRG("DA")=0:0
- SET GMRG("DA")=$ORDER(^GMRD(124.2,"AA",GMRG(3),GMRG(2),GMRG(1),GMRG(5),GMRG("DA")))
- if GMRG("DA")'>0
- QUIT
- IF GMRG("DA")'=DA
- SET GMRG("QT")=1
- QUIT
- +3 IF GMRG(5)'=""
- IF 'GMRG("QT")
- SET GMRG("NODE")=GMRG(5)
- GOTO S3
- +4 SET GMRG("QT")=0
- FOR GMRG("NODE")=1:1
- if $DATA(^GMRD(124.2,"AA",GMRG(3),GMRG(2),GMRG(1),GMRG("NODE"),DA))
- QUIT
- IF '$DATA(^GMRD(124.2,"AA",GMRG(3),GMRG(2),GMRG(1),GMRG("NODE")))
- if GMRG(5)'=""
- DO CLND
- if GMRG(5)=""!(GMRG(5)'=""&GMRG("QT"))
- QUIT
- +5 IF GMRG(5)'=""
- SET X=GMRG(5)
- FOR GMRG("L")=0:0
- SET GMRG("L")=$ORDER(^DD(124.2,.05,1,GMRG("L")))
- if GMRG("L")'>0
- QUIT
- if $DATA(^DD(124.2,.05,1,GMRG("L"),2))
- XECUTE ^(2)
- S3 SET X=GMRG("NODE")
- SET $PIECE(^GMRD(124.2,DA,0),"^",5)=X
- FOR GMRG("L")=0:0
- SET GMRG("L")=$ORDER(^DD(124.2,.05,1,GMRG("L")))
- if GMRG("L")'>0
- QUIT
- if $DATA(^DD(124.2,.05,1,GMRG("L"),1))
- XECUTE ^(1)
- +1 SET X=GMRG("X")
- Q3 KILL GMRG
- +1 QUIT
- CLND ;
- +1 SET GMRG("QT")=1
- FOR GMRG("DA")=0:0
- SET GMRG("DA")=$ORDER(^GMRD(124.2,"AA",GMRG(3),GMRG(2),GMRG(1),GMRG("NODE"),GMRG("DA")))
- if GMRG("DA")'>0
- QUIT
- IF GMRG("DA")'=DA
- SET GMRG("QT")=0
- QUIT
- +2 QUIT
- EN4 ; SCREEN FROM THE TYPE OF TERM (#.02) FIELD FROM AGGREGRATE TERM FILE
- +1 SET GMRG("L")=2
- SET GMRG("H")=4
- +2 SET GMRG=$ORDER(^GMRD(124.2,DA,1,"AC",0))
- if GMRG'=""
- SET GMRG("H")=2
- +3 IF Y'<GMRG("L")
- IF Y'>GMRG("H")
- +4 KILL GMRG
- +5 QUIT
- EN5 ; ENTRY TO SET LIST XREF OF THE SELECTION SUBFIELD (#.01) OF THE
- +1 ; SELECTION FIELD (#1) OF THE GMR TEXT (#124.3) FILE
- +2 SET GMRG(1)=$SELECT($DATA(^GMR(124.3,DA(2),1,DA(1),0)):$PIECE(^(0),U),1:"")
- if GMRG(1)'>0
- QUIT
- if '$DATA(^GMR(124.3,DA(2),1,"ALIST",GMRG(1),1))
- SET ^(1)="^0"
- +3 SET GMRGND=DA(2)
- SET GMRGND(0)=GMRG(1)
- DO STLST^GMRGRUT0
- +4 QUIT
- EN6 ; ENTRY TO KILL LIST XREF OF THE SELECTION SUBFIELD (#.01) OF THE
- +1 ; SELECTION FIELD (#1) OF THE GMR TEXT (#124.3) FILE
- +2 SET GMRG(1)=$SELECT($DATA(^GMR(124.3,DA(2),1,DA(1),0)):$PIECE(^(0),U),1:"")
- if GMRG(1)'>0
- QUIT
- FOR GMRG=0:0
- SET GMRG=$ORDER(^GMR(124.3,DA(2),1,"ALIST",GMRG(1),GMRG))
- if GMRG'>0
- QUIT
- KILL ^GMR(124.3,DA(2),1,"ALIST",GMRG(1),GMRG)
- +3 SET GMRGND=DA(2)
- SET GMRGND(0)=GMRG(1)
- DO DLLST^GMRGRUT0
- +4 QUIT
- EN7 ; ENTRY TO UPDATE ALIST XREF
- +1 IF '$DATA(GMRGRT)
- FOR GMRG(1)=0:0
- SET GMRG(1)=$ORDER(^GMR(124.3,DA(2),1,DA(1),2,GMRG(1)))
- if GMRG(1)'>0
- QUIT
- IF $DATA(^GMR(124.3,DA(2),1,DA(1),2,GMRG(1),0))
- IF $PIECE(^(0),"^")
- IF $SELECT(GMRG:1,GMRG(1)=DA:0,1:1)
- SET GMRG(1,(9999999-$PIECE(^(0),"^")))=$PIECE(^(0),"^",2)
- +2 SET GMRG(1)=$SELECT($DATA(GMRGRT):$ORDER(^GMR(124.3,DA(2),1,DA(1),2,"AA",0)),1:$ORDER(GMRG(1,0)))
- SET GMRG(2)=$SELECT($DATA(GMRGRT):$ORDER(^GMR(124.3,DA(2),1,DA(1),2,"AA",+GMRG(1),0)),$DATA(GMRG(1,+GMRG(1))):GMRG(1,GMRG(1)),1:0)
- +3 KILL GMRG(1)
- IF '$DATA(GMRGRT)
- IF GMRG(2)
- DO STPAR
- +4 if GMRG(2)
- DO EN5
- if 'GMRG(2)
- DO EN6
- KILL GMRG
- +5 QUIT
- STPAR ;
- +1 SET GMRG(1,0)=$SELECT($DATA(^GMR(124.3,DA(2),1,DA(1),0)):+$PIECE(^(0),"^"),1:0)
- if 'GMRG(1,0)
- QUIT
- if $SELECT('$DATA(^GMR(124.3,DA(2),0))
- SET GMRG(0,+^GMR(124.3,DA(2),0))=""
- +2 FOR GMRG(1)=0:0
- SET GMRG(1)=$ORDER(^GMR(124.3,DA(2),1,GMRG(1)))
- if GMRG(1)'>0
- QUIT
- IF $DATA(^GMR(124.3,DA(2),1,GMRG(1),0))
- IF $DATA(^GMRD(124.2,"AKID",GMRG(1,0),+^GMR(124.3,DA(2),1,GMRG(1),0)))
- DO STPAR1
- +3 QUIT
- STPAR1 ;
- +1 KILL GMRG("A")
- FOR GMRG(0)=0:0
- SET GMRG(0)=$ORDER(^GMR(124.3,DA(2),1,GMRG(1),2,GMRG(0)))
- if GMRG(0)'>0
- QUIT
- SET GMRG(3)=$SELECT($DATA(^GMR(124.3,DA(2),1,GMRG(1),2,GMRG(0),0)):^(0),1:"")
- IF +GMRG(3)
- SET GMRG("A",9999999-GMRG(3))=GMRG(3)
- +2 SET GMRG(0)=$ORDER(GMRG("A",0))
- if $SELECT('$DATA(GMRG("A",+GMRG(0)))
- SET GMRG(0,+^GMR(124.3,DA(2),1,GMRG(1),0))=""
- +3 QUIT