- NURCPPS2 ;HIRMFO/JH/RM-NURSING CARE PLAN DATABASE SEARCH part 2 ;4/17/92
- ;;4.0;NURSING SERVICE;;Apr 25, 1997
- ;This is a Cont. of Patient Problem Listing, Data Processor:
- PROB ; PROCESS PROBLEM LIST NURSP=AGGY IEN
- D STEVAL^NURCPPS4
- S NURSK=0,NURSL=NURSP,NURSDA=$O(^GMR(124.3,GMRGPDA,1,"B",NURSP,0)) D:NURSDA>0 STAUD^NURCPPS4
- I NURSPLN="C" S NURSI=$O(^TMP($J,"NURSDATE",NURSP,0)),NURSJ=$O(^(+NURSI,0)) I $D(^TMP($J,"NURSDATE",NURSP,+NURSI,+NURSJ)),"^R^S^U^"[("^"_$P(^(+NURSJ),"^",4)_"^") Q
- F NURSC=0:0 S NURSC=$O(^GMRD(124.2,NURSP,1,"B",NURSC)) Q:NURSC'>0 D:$D(^GMRD(124.2,"AKID",NURSC,NURSP,0)) PROBCHIL
- Q
- PROBCHIL ; PROCESS NURSP's CHILDREN
- ; NURSP=AGGY IEN OF PROBLEM, NURSC=AGGY IEN OF CHILD
- I NURSPLN="C" S NURSI=$O(^GMR(124.3,GMRGPDA,1,"B",NURSC,0)),NURSI=$O(^GMR(124.3,GMRGPDA,1,+NURSI,2,"AA",0)),NURSJ=$O(^(+NURSI,0)) Q:'NURSJ
- S NURSCHIL=$S($D(^GMRD(124.2,NURSC,0)):^(0),1:"")
- I '($P(NURSCHIL,"^",4)=NURSGCK!($P(NURSCHIL,"^",4)=NURSICK)) D NOGOIN^NURCPPS4 Q
- S NURSA=0,NURSG(0)=NURSC
- PCR ;
- S NURSA=NURSA+1
- F NURSG(NURSA)=0:0 S NURSG(NURSA)=$O(^GMRD(124.2,NURSC,1,"B",NURSG(NURSA))) Q:NURSG(NURSA)'>0 D:$D(^GMRD(124.2,"AKID",NURSG(NURSA),NURSC,0)) GIPR
- S NURSA=NURSA-1 S:NURSA NURSC=NURSG(NURSA-1)
- Q
- GIPR ;
- S X=$O(^GMRD(124.2,NURSC,1,"B",NURSG(NURSA),0)) Q:$P($G(^GMRD(124.2,NURSC,1,+X,0)),"^",6)!'$O(^GMR(124.3,GMRGPDA,1,$S(NURSPLN="A":"B",1:"ALIST"),NURSG(NURSA),0)) S NURSB(0)=$O(^GMR(124.3,GMRGPDA,1,"B",NURSG(NURSA),0)) Q:'NURSB(0)
- S NURSA(1)=$S($D(^GMRD(124.2,+NURSG(NURSA),0)):^(0),1:1)
- I NURSPLN="C",$P(NURSA(1),"^",4)=NURSGOCK S X=$O(^NURSC(216.8,NURSPOI,"TARG","AA",+NURSG(NURSA),0)),X=$O(^(+X,0)) I $P($G(^NURSC(216.8,NURSPOI,"TARG",+X,0)),"^",2) Q ;IF GOAL MET OR DC'D AND CURRENT REPORT, THEN DO NOT ADD TO SORT
- I NURSPLN="C",$P(NURSA(1),"^",4)=NURSINCK S X=$O(^NURSC(216.8,NURSPOI,"ORD","AA",+NURSG(NURSA),0)),X=$O(^(+X,0)) I $P($G(^NURSC(216.8,NURSPOI,"ORD",+X,0)),"^",3) Q ;IF ORDER DC'D AND CURRENT REPORT, THEN DO NOT ADD TO SORT
- I $P(NURSA(1),"^",4)=NURSGOCK!($P(NURSA(1),"^",4)=NURSINCK) S NURSG=NURSG(NURSA) D GOIN^NURCPPS4 Q
- S NURSB=NURSA-1*3,GMRGXPRT=$P(NURSA(1),"^"),GMRGXPRT(0)=$S($D(^GMR(124.3,GMRGPDA,1,NURSB(0),0)):$P(^(0),"^",2),1:""),GMRGXPRT(1)="0^245^0^0^1" D EN1^GMRGRUT2
- S:'$D(^TMP($J,"GMRGNAR",NURSG(0),NURSG(1),0)) ^(0)="0^0"
- S NURSO(0)=^TMP($J,"GMRGNAR",NURSG(0),NURSG(1),0),NURSO=$P(NURSO(0),"^",2)+1,GMRGPLN="-"_$S($E(GMRGXPRT)'?1L:$E(GMRGXPRT),1:$C($A($E(GMRGXPRT))-32))_$E(GMRGXPRT,2,$L(GMRGXPRT)),GMRGLEN=IOM-NURSRM-NURSB+1
- F NURSB(0)=0:1 D FITLINE^GMRGRUT1 S ^TMP($J,"GMRGNAR",NURSG(0),NURSG(1),NURSO)=$E(NURSSS,1,NURSB-1)_GMRGPLN(0),^(0)=NURSA_"^"_NURSO_"^"_NURSG(NURSA),NURSO=NURSO+1 Q:GMRGPLN(1)="" S GMRGPLN=" "_GMRGPLN(1),GMRGLEN=IOM-NURSRM-NURSB+1
- S NURSC=NURSG(NURSA) D PCR
- Q
- NURCPPS2 ;HIRMFO/JH/RM-NURSING CARE PLAN DATABASE SEARCH part 2 ;4/17/92
- +1 ;;4.0;NURSING SERVICE;;Apr 25, 1997
- +2 ;This is a Cont. of Patient Problem Listing, Data Processor:
- PROB ; PROCESS PROBLEM LIST NURSP=AGGY IEN
- +1 DO STEVAL^NURCPPS4
- +2 SET NURSK=0
- SET NURSL=NURSP
- SET NURSDA=$ORDER(^GMR(124.3,GMRGPDA,1,"B",NURSP,0))
- IF NURSDA>0
- DO STAUD^NURCPPS4
- +3 IF NURSPLN="C"
- SET NURSI=$ORDER(^TMP($JOB,"NURSDATE",NURSP,0))
- SET NURSJ=$ORDER(^(+NURSI,0))
- IF $DATA(^TMP($JOB,"NURSDATE",NURSP,+NURSI,+NURSJ))
- IF "^R^S^U^"[("^"_$PIECE(^(+NURSJ),"^",4)_"^")
- QUIT
- +4 FOR NURSC=0:0
- SET NURSC=$ORDER(^GMRD(124.2,NURSP,1,"B",NURSC))
- IF NURSC'>0
- QUIT
- IF $DATA(^GMRD(124.2,"AKID",NURSC,NURSP,0))
- DO PROBCHIL
- +5 QUIT
- PROBCHIL ; PROCESS NURSP's CHILDREN
- +1 ; NURSP=AGGY IEN OF PROBLEM, NURSC=AGGY IEN OF CHILD
- +2 IF NURSPLN="C"
- SET NURSI=$ORDER(^GMR(124.3,GMRGPDA,1,"B",NURSC,0))
- SET NURSI=$ORDER(^GMR(124.3,GMRGPDA,1,+NURSI,2,"AA",0))
- SET NURSJ=$ORDER(^(+NURSI,0))
- IF 'NURSJ
- QUIT
- +3 SET NURSCHIL=$SELECT($DATA(^GMRD(124.2,NURSC,0)):^(0),1:"")
- +4 IF '($PIECE(NURSCHIL,"^",4)=NURSGCK!($PIECE(NURSCHIL,"^",4)=NURSICK))
- DO NOGOIN^NURCPPS4
- QUIT
- +5 SET NURSA=0
- SET NURSG(0)=NURSC
- PCR ;
- +1 SET NURSA=NURSA+1
- +2 FOR NURSG(NURSA)=0:0
- SET NURSG(NURSA)=$ORDER(^GMRD(124.2,NURSC,1,"B",NURSG(NURSA)))
- IF NURSG(NURSA)'>0
- QUIT
- IF $DATA(^GMRD(124.2,"AKID",NURSG(NURSA),NURSC,0))
- DO GIPR
- +3 SET NURSA=NURSA-1
- IF NURSA
- SET NURSC=NURSG(NURSA-1)
- +4 QUIT
- GIPR ;
- +1 SET X=$ORDER(^GMRD(124.2,NURSC,1,"B",NURSG(NURSA),0))
- IF $PIECE($GET(^GMRD(124.2,NURSC,1,+X,0)),"^",6)!'$ORDER(^GMR(124.3,GMRGPDA,1,$SELECT(NURSPLN="A"
- QUIT
- SET NURSB(0)=$ORDER(^GMR(124.3,GMRGPDA,1,"B",NURSG(NURSA),0))
- IF 'NURSB(0)
- QUIT
- +2 SET NURSA(1)=$SELECT($DATA(^GMRD(124.2,+NURSG(NURSA),0)):^(0),1:1)
- +3 ;IF GOAL MET OR DC'D AND CURRENT REPORT, THEN DO NOT ADD TO SORT
- IF NURSPLN="C"
- IF $PIECE(NURSA(1),"^",4)=NURSGOCK
- SET X=$ORDER(^NURSC(216.8,NURSPOI,"TARG","AA",+NURSG(NURSA),0))
- SET X=$ORDER(^(+X,0))
- IF $PIECE($GET(^NURSC(216.8,NURSPOI,"TARG",+X,0)),"^",2)
- QUIT
- +4 ;IF ORDER DC'D AND CURRENT REPORT, THEN DO NOT ADD TO SORT
- IF NURSPLN="C"
- IF $PIECE(NURSA(1),"^",4)=NURSINCK
- SET X=$ORDER(^NURSC(216.8,NURSPOI,"ORD","AA",+NURSG(NURSA),0))
- SET X=$ORDER(^(+X,0))
- IF $PIECE($GET(^NURSC(216.8,NURSPOI,"ORD",+X,0)),"^",3)
- QUIT
- +5 IF $PIECE(NURSA(1),"^",4)=NURSGOCK!($PIECE(NURSA(1),"^",4)=NURSINCK)
- SET NURSG=NURSG(NURSA)
- DO GOIN^NURCPPS4
- QUIT
- +6 SET NURSB=NURSA-1*3
- SET GMRGXPRT=$PIECE(NURSA(1),"^")
- SET GMRGXPRT(0)=$SELECT($DATA(^GMR(124.3,GMRGPDA,1,NURSB(0),0)):$PIECE(^(0),"^",2),1:"")
- SET GMRGXPRT(1)="0^245^0^0^1"
- DO EN1^GMRGRUT2
- +7 IF '$DATA(^TMP($JOB,"GMRGNAR",NURSG(0),NURSG(1),0))
- SET ^(0)="0^0"
- +8 SET NURSO(0)=^TMP($JOB,"GMRGNAR",NURSG(0),NURSG(1),0)
- SET NURSO=$PIECE(NURSO(0),"^",2)+1
- SET GMRGPLN="-"_$SELECT($EXTRACT(GMRGXPRT)'?1L:$EXTRACT(GMRGXPRT),1:$CHAR($ASCII($EXTRACT(GMRGXPRT))-32))_$EXTRACT(GMRGXPRT,2,$LENGTH(GMRGXPRT))
- SET GMRGLEN=IOM-NURSRM-NURSB+1
- +9 FOR NURSB(0)=0:1
- DO FITLINE^GMRGRUT1
- SET ^TMP($JOB,"GMRGNAR",NURSG(0),NURSG(1),NURSO)=$EXTRACT(NURSSS,1,NURSB-1)_GMRGPLN(0)
- SET ^(0)=NURSA_"^"_NURSO_"^"_NURSG(NURSA)
- SET NURSO=NURSO+1
- IF GMRGPLN(1)=""
- QUIT
- SET GMRGPLN=" "_GMRGPLN(1)
- SET GMRGLEN=IOM-NURSRM-NURSB+1
- +10 SET NURSC=NURSG(NURSA)
- DO PCR
- +11 QUIT
