- NURCCPU3 ;HIRMFO/RD/RM,RTK/MD-NURSING CARE PLAN UTILITIES (cont.) ;8/16/95
- ;;4.0;NURSING SERVICE;;Apr 25, 1997
- EN1 ;ENTRY POINT TP PRINT DISCONTINUE DATES OF ANY ORDERS IN THE LIST
- ;OF ACTIVE INTERVENTIONS
- Q:'$P(GMRGSEL,"^",3)
- S NURSORD=$O(^NURSC(216.8,NURSCPE,"ORD","AA",$P(GMRGSEL,"^"),0)) G:NURSORD'>0 Q1 S NURSORD1=$O(^(NURSORD,0)) G:NURSORD1'>0 Q1 S NURORDT=$S($D(^NURSC(216.8,NURSCPE,"ORD",NURSORD1,0)):^(0),1:"")
- G Q1:'$P(NURORDT,"^",3) S Y=$P(NURORDT,"^"),NURDATE=$S(Y:$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3),1:"")
- S GMRGHPRT(1)="67^"_NURDATE_"/DC"
- Q1 ;
- K NURSORD,NURSORD1,NURORDT,Y,NURDATE
- Q
- EN2 ; UPON EXITING A NURSING PROBLEM, UPDATE STATUS ALSO KILL NURSPROB
- G:'$D(^GMR(124.3,GMRGPDA,1,"ALIST",+GMRGTERM))!GMRGOUT Q2
- S NURSEVAL=$O(^NURSC(216.8,NURSCPE,"EVAL","AA",+GMRGTERM,0)),NURSEVDA=$O(^NURSC(216.8,NURSCPE,"EVAL","AA",+GMRGTERM,+NURSEVAL,0))
- S NURSEVND=$G(^NURSC(216.8,NURSCPE,"EVAL",+NURSEVDA,0)),NURSTAT=+$P(NURSEVND,"^",4),NURSREEV=$P(NURSEVND,"^",5)
- W !!,$C(7),$S(NURSEVDA>0:"Last evaluation for ",1:"")
- S GMRGXPRT="'"_$P(GMRGTERM,"^",2),GMRGXPRT(0)=$S($P(GMRGTERM,"^",3)="":"",$D(^GMR(124.3,GMRGPDA,1,$P(GMRGTERM,"^",3),0)):$P(^(0),"^",2),1:""),GMRGXPRT(1)=$S(NURSEVDA>0:20,1:0)_"^"_IOM_"^1^0"
- I $P(GMRGXPRT(0),"|")'="" S $P(GMRGXPRT(0),"|")=$P(GMRGXPRT(0),"|")_"'"
- E S GMRGXPRT=GMRGXPRT_"'"
- D EN1^GMRGRUT2
- I NURSEVDA>0 D
- . W !?5,"Evaluation Date: " S Y=NURSREEV D DT^DIQ Q
- E W !,"has no previous evaluation."
- W !
- K DIR S DIR(0)="SOA^A:Active;R:Resolved;S:Suspended;U:Unresolved @ Discharge",DIR("A")="PROBLEM STATUS: ",DIR("B")=$P("Active^Resolved^Suspended^Unresolved @ Discharge",U,NURSTAT+1)
- S DIR("?",1)=" The following are valid responses:",DIR("?",2)=" A if problem is still ACTIVE",DIR("?",3)=" R if problem is RESOLVED",DIR("?",4)=" S if problem has been SUSPENDED"
- S DIR("?",5)=" U if problem was UNRESOLVED @ DISCHARGE",DIR("?")=" Enter the appropriate status of the problem."
- D ^DIR K DIR I "^^"[Y S GMRGOUT=1 G Q2
- S NURSTAT=$F("ARSU",Y)-2
- I 'NURSTAT D
- . I $P(NURSEVND,U,4) W !,"THIS PROBLEM WILL BE REOPENED."
- . S NURDFLT=$P($G(^DIC(213.9,1,"CPD")),U),NURDFLT=$S(NURDFLT]"":NURDFLT,1:"T+5") ; default evaluation date
- . K DIR S DIR(0)="DA^"_DT_"::E",DIR("A")="DATE PROBLEM TO BE RE-EVALUATED: ",DIR("B")=$S(NURSREEV<DT:NURDFLT,1:$$FMTE^XLFDT(NURSREEV))
- . S DIR("?",1)="Enter the date that this problem should be re-evaluated.",DIR("?")="Please use valid FileMan date format."
- . D ^DIR K DIR I "^^"[Y S GMRGOUT=1 Q
- . S NURSREEV=Y
- . Q
- E S:NURSTAT'=$P(NURSEVND,"^",4) NURSREEV=DT S:$D(NCPFLG) NCPFLG=0
- G Q2:(NURSTAT_"^"_NURSREEV)=$P(NURSEVND,"^",4,5)
- I '$D(^NURSC(216.8,NURSCPE,"EVAL",0)) S ^(0)="^216.82DI^^"
- S DA(1)=NURSCPE,NURSZN=$P(^NURSC(216.8,NURSCPE,"EVAL",0),"^",3,4),DA=$P(NURSZN,"^",1)+1,NURSNUM=$P(NURSZN,"^",2) F DA=DA:1 Q:'$D(^NURSC(216.8,NURSCPE,"EVAL",DA,0))
- S NURSNWDT=$$HTFM^XLFDT($H),$P(^NURSC(216.8,DA(1),"EVAL",0),"^",3,4)=DA_"^"_(NURSNUM+1),^NURSC(216.8,DA(1),"EVAL",DA,0)=NURSNWDT_"^"_$P(GMRGTERM,"^")_"^^"_NURSTAT_"^"_NURSREEV
- S DIK="^NURSC(216.8,"_DA(1)_",""EVAL""," D IX1^DIK
- I "^1^2^3^"[("^"_NURSTAT_"^"),'$P(NURSEVND,"^",4) D DCINT^NURCCPU5,METGOAL^NURCCPU5($S(NURSTAT=1:1,1:2)) ;**WAIT FOR EP DECISION ON THIS AS FAR AS UPDATING STATUS**
- Q2 K %,%DT,DA,NURDFLT,NURSEVAL,NURSEVND,NURSEVDA,NURSI,NURSJ,NURSNUM,NURSNWDT,NURSTAT,NURSREEV,NURSZN,NURFLAG,X,NURSORD,NURSINT
- I $D(NURSPROB) K NURSPROB(NURSPROB) S NURSPROB=NURSPROB-1 K:'NURSPROB NURSPROB
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURCCPU3 3527 printed Feb 18, 2025@23:46:42 Page 2
- NURCCPU3 ;HIRMFO/RD/RM,RTK/MD-NURSING CARE PLAN UTILITIES (cont.) ;8/16/95
- +1 ;;4.0;NURSING SERVICE;;Apr 25, 1997
- EN1 ;ENTRY POINT TP PRINT DISCONTINUE DATES OF ANY ORDERS IN THE LIST
- +1 ;OF ACTIVE INTERVENTIONS
- +2 if '$PIECE(GMRGSEL,"^",3)
- QUIT
- +3 SET NURSORD=$ORDER(^NURSC(216.8,NURSCPE,"ORD","AA",$PIECE(GMRGSEL,"^"),0))
- if NURSORD'>0
- GOTO Q1
- SET NURSORD1=$ORDER(^(NURSORD,0))
- if NURSORD1'>0
- GOTO Q1
- SET NURORDT=$SELECT($DATA(^NURSC(216.8,NURSCPE,"ORD",NURSORD1,0)):^(0),1:"")
- +4 if '$PIECE(NURORDT,"^",3)
- GOTO Q1
- SET Y=$PIECE(NURORDT,"^")
- SET NURDATE=$SELECT(Y:$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3),1:"")
- +5 SET GMRGHPRT(1)="67^"_NURDATE_"/DC"
- Q1 ;
- +1 KILL NURSORD,NURSORD1,NURORDT,Y,NURDATE
- +2 QUIT
- EN2 ; UPON EXITING A NURSING PROBLEM, UPDATE STATUS ALSO KILL NURSPROB
- +1 if '$DATA(^GMR(124.3,GMRGPDA,1,"ALIST",+GMRGTERM))!GMRGOUT
- GOTO Q2
- +2 SET NURSEVAL=$ORDER(^NURSC(216.8,NURSCPE,"EVAL","AA",+GMRGTERM,0))
- SET NURSEVDA=$ORDER(^NURSC(216.8,NURSCPE,"EVAL","AA",+GMRGTERM,+NURSEVAL,0))
- +3 SET NURSEVND=$GET(^NURSC(216.8,NURSCPE,"EVAL",+NURSEVDA,0))
- SET NURSTAT=+$PIECE(NURSEVND,"^",4)
- SET NURSREEV=$PIECE(NURSEVND,"^",5)
- +4 WRITE !!,$CHAR(7),$SELECT(NURSEVDA>0:"Last evaluation for ",1:"")
- +5 SET GMRGXPRT="'"_$PIECE(GMRGTERM,"^",2)
- SET GMRGXPRT(0)=$SELECT($PIECE(GMRGTERM,"^",3)="":"",$DATA(^GMR(124.3,GMRGPDA,1,$PIECE(GMRGTERM,"^",3),0)):$PIECE(^(0),"^",2),1:"")
- SET GMRGXPRT(1)=$SELECT(NURSEVDA>0:20,1:0)_"^"_IOM_"^1^0"
- +6 IF $PIECE(GMRGXPRT(0),"|")'=""
- SET $PIECE(GMRGXPRT(0),"|")=$PIECE(GMRGXPRT(0),"|")_"'"
- +7 IF '$TEST
- SET GMRGXPRT=GMRGXPRT_"'"
- +8 DO EN1^GMRGRUT2
- +9 IF NURSEVDA>0
- Begin DoDot:1
- +10 WRITE !?5,"Evaluation Date: "
- SET Y=NURSREEV
- DO DT^DIQ
- QUIT
- End DoDot:1
- +11 IF '$TEST
- WRITE !,"has no previous evaluation."
- +12 WRITE !
- +13 KILL DIR
- SET DIR(0)="SOA^A:Active;R:Resolved;S:Suspended;U:Unresolved @ Discharge"
- SET DIR("A")="PROBLEM STATUS: "
- SET DIR("B")=$PIECE("Active^Resolved^Suspended^Unresolved @ Discharge",U,NURSTAT+1)
- +14 SET DIR("?",1)=" The following are valid responses:"
- SET DIR("?",2)=" A if problem is still ACTIVE"
- SET DIR("?",3)=" R if problem is RESOLVED"
- SET DIR("?",4)=" S if problem has been SUSPENDED"
- +15 SET DIR("?",5)=" U if problem was UNRESOLVED @ DISCHARGE"
- SET DIR("?")=" Enter the appropriate status of the problem."
- +16 DO ^DIR
- KILL DIR
- IF "^^"[Y
- SET GMRGOUT=1
- GOTO Q2
- +17 SET NURSTAT=$FIND("ARSU",Y)-2
- +18 IF 'NURSTAT
- Begin DoDot:1
- +19 IF $PIECE(NURSEVND,U,4)
- WRITE !,"THIS PROBLEM WILL BE REOPENED."
- +20 ; default evaluation date
- SET NURDFLT=$PIECE($GET(^DIC(213.9,1,"CPD")),U)
- SET NURDFLT=$SELECT(NURDFLT]"":NURDFLT,1:"T+5")
- +21 KILL DIR
- SET DIR(0)="DA^"_DT_"::E"
- SET DIR("A")="DATE PROBLEM TO BE RE-EVALUATED: "
- SET DIR("B")=$SELECT(NURSREEV<DT:NURDFLT,1:$$FMTE^XLFDT(NURSREEV))
- +22 SET DIR("?",1)="Enter the date that this problem should be re-evaluated."
- SET DIR("?")="Please use valid FileMan date format."
- +23 DO ^DIR
- KILL DIR
- IF "^^"[Y
- SET GMRGOUT=1
- QUIT
- +24 SET NURSREEV=Y
- +25 QUIT
- End DoDot:1
- +26 IF '$TEST
- if NURSTAT'=$PIECE(NURSEVND,"^",4)
- SET NURSREEV=DT
- if $DATA(NCPFLG)
- SET NCPFLG=0
- +27 if (NURSTAT_"^"_NURSREEV)=$PIECE(NURSEVND,"^",4,5)
- GOTO Q2
- +28 IF '$DATA(^NURSC(216.8,NURSCPE,"EVAL",0))
- SET ^(0)="^216.82DI^^"
- +29 SET DA(1)=NURSCPE
- SET NURSZN=$PIECE(^NURSC(216.8,NURSCPE,"EVAL",0),"^",3,4)
- SET DA=$PIECE(NURSZN,"^",1)+1
- SET NURSNUM=$PIECE(NURSZN,"^",2)
- FOR DA=DA:1
- if '$DATA(^NURSC(216.8,NURSCPE,"EVAL",DA,0))
- QUIT
- +30 SET NURSNWDT=$$HTFM^XLFDT($HOROLOG)
- SET $PIECE(^NURSC(216.8,DA(1),"EVAL",0),"^",3,4)=DA_"^"_(NURSNUM+1)
- SET ^NURSC(216.8,DA(1),"EVAL",DA,0)=NURSNWDT_"^"_$PIECE(GMRGTERM,"^")_"^^"_NURSTAT_"^"_NURSREEV
- +31 SET DIK="^NURSC(216.8,"_DA(1)_",""EVAL"","
- DO IX1^DIK
- +32 ;**WAIT FOR EP DECISION ON THIS AS FAR AS UPDATING STATUS**
- IF "^1^2^3^"[("^"_NURSTAT_"^")
- IF '$PIECE(NURSEVND,"^",4)
- DO DCINT^NURCCPU5
- DO METGOAL^NURCCPU5($SELECT(NURSTAT=1:1,1:2))
- Q2 KILL %,%DT,DA,NURDFLT,NURSEVAL,NURSEVND,NURSEVDA,NURSI,NURSJ,NURSNUM,NURSNWDT,NURSTAT,NURSREEV,NURSZN,NURFLAG,X,NURSORD,NURSINT
- +1 IF $DATA(NURSPROB)
- KILL NURSPROB(NURSPROB)
- SET NURSPROB=NURSPROB-1
- if 'NURSPROB
- KILL NURSPROB
- +2 QUIT