- GMRGED7 ;HIRMFO/RM-PATIENT DATA EDIT (cont.) ;1/9/96
- ;;3.0;Text Generator;;Jan 24, 1996
- NOTMIN ; IF THE MINIMUM NUMBER OF SELECTIONS IS NOT MADE FOR A FRAME
- ; THEN THAT FRAME AND ALL SELECTED CHILDREN WILL BE DELETED.
- S GMRGDLT("G")="",GMRGDLT("P")=$P(GMRGTERM,"^"),GMRGDLT("T")=$P(GMRGTERM,"^",3)
- NMIN ; LOOP THROUGH CHILDREN (TO DELETE IF NECESSARY) AND DELETE THE
- ; TERM ID'D BY GMRGDLT("P") IF NECESSARY.
- ;
- ; THE FOLLOWING 3 LINES OF COMMENTED CODE WILL BE SAVED UNTIL TG V4.
- ; THEY MAY BE NEEDED IF THE FIX IN THE TWO LINES THAT FOLLOW THEM
- ; CAUSE ANY PROBLEMS.
- ;F GMRGDLT("C")=0:0 S GMRGDLT("C")=$O(^GMRD(124.2,GMRGDLT("P"),1,"B",GMRGDLT("C"))) Q:GMRGDLT("C")'>0 I $D(^GMR(124.3,GMRGPDA,1,"ALIST",GMRGDLT("C"))) D CHMIN
- ;S GMRGTDL(0)=0 I GMRGDLT("G")'="" S GMRGND=GMRGDLT("P") F GMRGTDL=0:0 S GMRGTDL=$O(^GMRD(124.2,"AKID",GMRGDLT("P"),GMRGTDL)) Q:GMRGTDL'>0 I GMRGTDL'=GMRGDLT("G"),$D(^GMR(124.3,GMRGPDA,1,"ALIST",GMRGTDL)) S GMRGTDL(0)=1 Q
- ;I 'GMRGTDL(0),GMRGDLT("T")>0,GMRGDLT("P")'=+GMRGRT D DELMIN
- F GMRGDLT("C")=0:0 S GMRGDLT("C")=$O(^GMRD(124.2,GMRGDLT("P"),1,"B",GMRGDLT("C"))) Q:GMRGDLT("C")'>0 I '$$OTHPAR(GMRGPDA,GMRGDLT("C"),GMRGDLT("P")),$D(^GMR(124.3,GMRGPDA,1,"ALIST",GMRGDLT("C"))) D CHMIN
- I '$$OTHPAR(GMRGPDA,GMRGDLT("P"),GMRGDLT("G")),GMRGDLT("T")>0,GMRGDLT("P")'=+GMRGRT D DELMIN
- Q
- CHMIN ; CALL NMIN RECURSIVELY FOR THE CHILDREN ACTIVE IN THE PLAN
- S GMRGTDL(0)=GMRGDLT("P"),GMRGTDL=GMRGDLT("C") N GMRGDLT S GMRGDLT("G")=GMRGTDL(0),GMRGDLT("P")=GMRGTDL
- S GMRGDLT("T")=$O(^GMR(124.3,GMRGPDA,1,"B",GMRGDLT("P"),0)) Q:GMRGDLT("T")'>0 Q:'$D(^GMR(124.3,GMRGPDA,1,GMRGDLT("T"),0))
- D NMIN
- Q
- DELMIN ; DELETE THIS ENTRY FROM THE PLAN
- S GMRGTDL=0,GMRGDLT(0)=$G(^GMR(124.3,GMRGPDA,1,GMRGDLT("T"),0))
- I '$P(GMRGDLT(0),"^",3) F GMRG1=0:0 S GMRG1=$O(^GMR(124.3,GMRGPDA,1,GMRGDLT("T"),2,"AA",GMRG1)) S:GMRG1'>0 GMRGTDL=1 Q:GMRG1'>0 D DMIN Q:'GMRG1(1)
- I GMRGTDL,'$P(GMRGDLT(0),"^",3) S DA(1)=GMRGPDA,DA=GMRGDLT("T"),DIK="^GMR(124.3,DA(1),1," D ^DIK
- I $P(GMRGDLT(0),"^",3) S DA(1)=GMRGPDA,DA=GMRGDLT("T"),GMRGY=0,X=$P(GMRGDLT(0),"^") D EN1^GMRGUTL ;WE MAY HAVE TO EXECUTE ACTION ON FILING HERE, NOT SURE AT THIS TIME.
- Q
- DMIN ;
- S GMRG1(0)=$O(^GMR(124.3,GMRGPDA,1,GMRGDLT("T"),2,"AA",GMRG1,"")),DA=$S(GMRG1(0)="":0,1:$O(^GMR(124.3,GMRGPDA,1,GMRGDLT("T"),2,"AA",GMRG1,GMRG1(0),0)))
- S GMRG1(0)=$S(DA'>0:"",$D(^GMR(124.3,GMRGPDA,1,GMRGDLT("T"),2,DA,0)):^(0),1:"") Q:GMRG1(0)'>0
- S GMRG1(1)=$P(GMRG1(0),"^",2) Q:'GMRG1(1) S DA(2)=GMRGPDA,DA(1)=GMRGDLT("T")
- I $D(^GMR(124.3,DA(2),1,DA(1),2,DA,"ADD")),^("ADD")'="" D ADM
- I $D(^GMR(124.3,DA(2),1,DA(1),2,DA,0)),$P(^(0),"^",4)'="" D APM
- S DIK="^GMR(124.3,DA(2),1,DA(1),2," D ^DIK
- Q
- ADM ;
- S GMRG1=DA,DA=DA(1),DA(1)=DA(2) K DA(2) S X=$S($D(^GMR(124.3,DA(1),1,DA,"ADD")):^("ADD"),1:"") I X'="" F GMRG2=0:0 S GMRG2=$O(^DD(124.31,2,1,GMRG2)) Q:GMRG2'>0 X:$D(^DD(124.31,2,1,GMRG2,2)) ^(2)
- S X=^GMR(124.3,DA(1),1,DA,2,GMRG1,"ADD") F GMRG2=0:0 S GMRG2=$O(^DD(124.31,2,1,GMRG2)) Q:GMRG2'>0 X:$D(^DD(124.31,2,1,GMRG2,1)) ^(1)
- S DA(2)=DA(1),DA(1)=DA,DA=GMRG1
- Q
- APM ;
- S GMRG1=DA,DA=DA(1),DA(1)=DA(2) K DA(2) S X=$S($D(^GMR(124.3,DA(1),1,DA,0)):$P(^(0),"^",2),1:"") I X'="" F GMRG2=0:0 S GMRG2=$O(^DD(124.31,1,1,GMRG2)) Q:GMRG2'>0 X:$D(^DD(124.31,1,1,GMRG2,2)) ^(2)
- S X=$P(^GMR(124.3,DA(1),1,DA,2,GMRG1,0),"^",4) F GMRG2=0:0 S GMRG2=$O(^DD(124.31,1,1,GMRG2)) Q:GMRG2'>0 X:$D(^DD(124.31,1,1,GMRG2,1)) ^(1)
- S DA(2)=DA(1),DA(1)=DA,DA=GMRG1
- Q
- BEGADD ; IF THE RECORD WHICH IS ABOUT TO BE EDITED HAS ANY ADDED FLAGS
- ; WHICH INDICATED NO THEN THESE FLAGS WILL BE FLIPPED TO INDICATE YES
- S DA(1)=GMRGPDA F DA=0:0 S DA=$O(^GMR(124.3,GMRGPDA,1,"ANOT",DA)) Q:DA'>0 I $D(^GMR(124.3,DA(1),1,DA,0)),'$P(^(0),"^",3) S GMRGTERM=$P(^(0),"^",1,2)_"^"_DA,GMRGTERM(0)=$S($D(^GMRD(124.2,+GMRGTERM,0)):^(0),1:"") D ADS^GMRGED6
- Q
- OTHPAR(IEN,CHIL,PAR) ; Given the IEN of 124.3 entry (IEN) and Aggregate
- ; Term file pointers for the Child (CHIL) and Parent (PARN), this
- ; function will return True (1) if CHIL has another parent'=PARN
- ; that it is active for in IEN, else the function returns False (0).
- N FXN,X S FXN=0
- I PAR'="" S X=0 F S X=$O(^GMRD(124.2,"AKID",CHIL,X)) Q:X'>0 I X'=PAR,$D(^GMR(124.3,IEN,1,"ALIST",X)) S FXN=1 Q
- Q FXN
- GMRGED7 ;HIRMFO/RM-PATIENT DATA EDIT (cont.) ;1/9/96
- +1 ;;3.0;Text Generator;;Jan 24, 1996
- NOTMIN ; IF THE MINIMUM NUMBER OF SELECTIONS IS NOT MADE FOR A FRAME
- +1 ; THEN THAT FRAME AND ALL SELECTED CHILDREN WILL BE DELETED.
- +2 SET GMRGDLT("G")=""
- SET GMRGDLT("P")=$PIECE(GMRGTERM,"^")
- SET GMRGDLT("T")=$PIECE(GMRGTERM,"^",3)
- NMIN ; LOOP THROUGH CHILDREN (TO DELETE IF NECESSARY) AND DELETE THE
- +1 ; TERM ID'D BY GMRGDLT("P") IF NECESSARY.
- +2 ;
- +3 ; THE FOLLOWING 3 LINES OF COMMENTED CODE WILL BE SAVED UNTIL TG V4.
- +4 ; THEY MAY BE NEEDED IF THE FIX IN THE TWO LINES THAT FOLLOW THEM
- +5 ; CAUSE ANY PROBLEMS.
- +6 ;F GMRGDLT("C")=0:0 S GMRGDLT("C")=$O(^GMRD(124.2,GMRGDLT("P"),1,"B",GMRGDLT("C"))) Q:GMRGDLT("C")'>0 I $D(^GMR(124.3,GMRGPDA,1,"ALIST",GMRGDLT("C"))) D CHMIN
- +7 ;S GMRGTDL(0)=0 I GMRGDLT("G")'="" S GMRGND=GMRGDLT("P") F GMRGTDL=0:0 S GMRGTDL=$O(^GMRD(124.2,"AKID",GMRGDLT("P"),GMRGTDL)) Q:GMRGTDL'>0 I GMRGTDL'=GMRGDLT("G"),$D(^GMR(124.3,GMRGPDA,1,"ALIST",GMRGTDL)) S GMRGTDL(0)=1 Q
- +8 ;I 'GMRGTDL(0),GMRGDLT("T")>0,GMRGDLT("P")'=+GMRGRT D DELMIN
- +9 FOR GMRGDLT("C")=0:0
- SET GMRGDLT("C")=$ORDER(^GMRD(124.2,GMRGDLT("P"),1,"B",GMRGDLT("C")))
- IF GMRGDLT("C")'>0
- QUIT
- IF '$$OTHPAR(GMRGPDA,GMRGDLT("C"),GMRGDLT("P"))
- IF $DATA(^GMR(124.3,GMRGPDA,1,"ALIST",GMRGDLT("C")))
- DO CHMIN
- +10 IF '$$OTHPAR(GMRGPDA,GMRGDLT("P"),GMRGDLT("G"))
- IF GMRGDLT("T")>0
- IF GMRGDLT("P")'=+GMRGRT
- DO DELMIN
- +11 QUIT
- CHMIN ; CALL NMIN RECURSIVELY FOR THE CHILDREN ACTIVE IN THE PLAN
- +1 SET GMRGTDL(0)=GMRGDLT("P")
- SET GMRGTDL=GMRGDLT("C")
- NEW GMRGDLT
- SET GMRGDLT("G")=GMRGTDL(0)
- SET GMRGDLT("P")=GMRGTDL
- +2 SET GMRGDLT("T")=$ORDER(^GMR(124.3,GMRGPDA,1,"B",GMRGDLT("P"),0))
- IF GMRGDLT("T")'>0
- QUIT
- IF '$DATA(^GMR(124.3,GMRGPDA,1,GMRGDLT("T"),0))
- QUIT
- +3 DO NMIN
- +4 QUIT
- DELMIN ; DELETE THIS ENTRY FROM THE PLAN
- +1 SET GMRGTDL=0
- SET GMRGDLT(0)=$GET(^GMR(124.3,GMRGPDA,1,GMRGDLT("T"),0))
- +2 IF '$PIECE(GMRGDLT(0),"^",3)
- FOR GMRG1=0:0
- SET GMRG1=$ORDER(^GMR(124.3,GMRGPDA,1,GMRGDLT("T"),2,"AA",GMRG1))
- IF GMRG1'>0
- SET GMRGTDL=1
- IF GMRG1'>0
- QUIT
- DO DMIN
- IF 'GMRG1(1)
- QUIT
- +3 IF GMRGTDL
- IF '$PIECE(GMRGDLT(0),"^",3)
- SET DA(1)=GMRGPDA
- SET DA=GMRGDLT("T")
- SET DIK="^GMR(124.3,DA(1),1,"
- DO ^DIK
- +4 ;WE MAY HAVE TO EXECUTE ACTION ON FILING HERE, NOT SURE AT THIS TIME.
- IF $PIECE(GMRGDLT(0),"^",3)
- SET DA(1)=GMRGPDA
- SET DA=GMRGDLT("T")
- SET GMRGY=0
- SET X=$PIECE(GMRGDLT(0),"^")
- DO EN1^GMRGUTL
- +5 QUIT
- DMIN ;
- +1 SET GMRG1(0)=$ORDER(^GMR(124.3,GMRGPDA,1,GMRGDLT("T"),2,"AA",GMRG1,""))
- SET DA=$SELECT(GMRG1(0)="":0,1:$ORDER(^GMR(124.3,GMRGPDA,1,GMRGDLT("T"),2,"AA",GMRG1,GMRG1(0),0)))
- +2 SET GMRG1(0)=$SELECT(DA'>0:"",$DATA(^GMR(124.3,GMRGPDA,1,GMRGDLT("T"),2,DA,0)):^(0),1:"")
- IF GMRG1(0)'>0
- QUIT
- +3 SET GMRG1(1)=$PIECE(GMRG1(0),"^",2)
- IF 'GMRG1(1)
- QUIT
- SET DA(2)=GMRGPDA
- SET DA(1)=GMRGDLT("T")
- +4 IF $DATA(^GMR(124.3,DA(2),1,DA(1),2,DA,"ADD"))
- IF ^("ADD")'=""
- DO ADM
- +5 IF $DATA(^GMR(124.3,DA(2),1,DA(1),2,DA,0))
- IF $PIECE(^(0),"^",4)'=""
- DO APM
- +6 SET DIK="^GMR(124.3,DA(2),1,DA(1),2,"
- DO ^DIK
- +7 QUIT
- ADM ;
- +1 SET GMRG1=DA
- SET DA=DA(1)
- SET DA(1)=DA(2)
- KILL DA(2)
- SET X=$SELECT($DATA(^GMR(124.3,DA(1),1,DA,"ADD")):^("ADD"),1:"")
- IF X'=""
- FOR GMRG2=0:0
- SET GMRG2=$ORDER(^DD(124.31,2,1,GMRG2))
- IF GMRG2'>0
- QUIT
- IF $DATA(^DD(124.31,2,1,GMRG2,2))
- XECUTE ^(2)
- +2 SET X=^GMR(124.3,DA(1),1,DA,2,GMRG1,"ADD")
- FOR GMRG2=0:0
- SET GMRG2=$ORDER(^DD(124.31,2,1,GMRG2))
- IF GMRG2'>0
- QUIT
- IF $DATA(^DD(124.31,2,1,GMRG2,1))
- XECUTE ^(1)
- +3 SET DA(2)=DA(1)
- SET DA(1)=DA
- SET DA=GMRG1
- +4 QUIT
- APM ;
- +1 SET GMRG1=DA
- SET DA=DA(1)
- SET DA(1)=DA(2)
- KILL DA(2)
- SET X=$SELECT($DATA(^GMR(124.3,DA(1),1,DA,0)):$PIECE(^(0),"^",2),1:"")
- IF X'=""
- FOR GMRG2=0:0
- SET GMRG2=$ORDER(^DD(124.31,1,1,GMRG2))
- IF GMRG2'>0
- QUIT
- IF $DATA(^DD(124.31,1,1,GMRG2,2))
- XECUTE ^(2)
- +2 SET X=$PIECE(^GMR(124.3,DA(1),1,DA,2,GMRG1,0),"^",4)
- FOR GMRG2=0:0
- SET GMRG2=$ORDER(^DD(124.31,1,1,GMRG2))
- IF GMRG2'>0
- QUIT
- IF $DATA(^DD(124.31,1,1,GMRG2,1))
- XECUTE ^(1)
- +3 SET DA(2)=DA(1)
- SET DA(1)=DA
- SET DA=GMRG1
- +4 QUIT
- BEGADD ; IF THE RECORD WHICH IS ABOUT TO BE EDITED HAS ANY ADDED FLAGS
- +1 ; WHICH INDICATED NO THEN THESE FLAGS WILL BE FLIPPED TO INDICATE YES
- +2 SET DA(1)=GMRGPDA
- FOR DA=0:0
- SET DA=$ORDER(^GMR(124.3,GMRGPDA,1,"ANOT",DA))
- IF DA'>0
- QUIT
- IF $DATA(^GMR(124.3,DA(1),1,DA,0))
- IF '$PIECE(^(0),"^",3)
- SET GMRGTERM=$PIECE(^(0),"^",1,2)_"^"_DA
- SET GMRGTERM(0)=$SELECT($DATA(^GMRD(124.2,+GMRGTERM,0)):^(0),1:"")
- DO ADS^GMRGED6
- +3 QUIT
- OTHPAR(IEN,CHIL,PAR) ; Given the IEN of 124.3 entry (IEN) and Aggregate
- +1 ; Term file pointers for the Child (CHIL) and Parent (PARN), this
- +2 ; function will return True (1) if CHIL has another parent'=PARN
- +3 ; that it is active for in IEN, else the function returns False (0).
- +4 NEW FXN,X
- SET FXN=0
- +5 IF PAR'=""
- SET X=0
- FOR
- SET X=$ORDER(^GMRD(124.2,"AKID",CHIL,X))
- IF X'>0
- QUIT
- IF X'=PAR
- IF $DATA(^GMR(124.3,IEN,1,"ALIST",X))
- SET FXN=1
- QUIT
- +6 QUIT FXN
