NURCEVP0 ;HIRMFO/RTK,RM,MD-Nursing Care Plans Print Report ;8/29/96
;;4.0;NURSING SERVICE;;Apr 25, 1997
ENT1 ;
S GMRGRT=$O(^GMRD(124.2,"AA","NURSC",2,"Nursing Care Plan","")) I GMRGRT'>0 W !,$C(7),"THERE IS A PROBLEM IN THE ""AA"" XREF.",! G END
S GMRGRT=GMRGRT_"^Nursing Care Plan"
S NACT=0 D WARDPAT^NURCUT0 G:NURQUIT END
DEV ; SELECT DEVICE TO SEND OUTPUT TO.
; IF REPORT IS QUEUED, SET UP TASK USING %ZTLOAD AND GET OUT OF ROUTINE
S ZTRTN="PRINT^NURCEVP0",ZTDESC="Nursing Care Plan Print Report" D EN7^NURSUT0 K ZTDESC,NURQUEUE I POP!$D(ZTSK) K POP,ZTSK G END
;
PRINT ; ENTRY FROM TASKMAN TO PRINT THIS REPORT
S (PAGE,NURSW1,NUROUT)=0 K ^TMP($J) F X="NURCHC","NURPROB" K ^TMP(X,$J)
D ^NURCAS2 ; BUILDS ^TMP($J,"NURCEN",ROOM,BED,PATNAME) ARRAY
S ROOM="" F S ROOM=$O(^TMP($J,"NURCEN",ROOM)) Q:ROOM="" S BED="" F S BED=$O(^TMP($J,"NURCEN",ROOM,BED)) Q:BED="" S PATNAME="" F S PATNAME=$O(^TMP($J,"NURCEN",ROOM,BED,PATNAME)) Q:PATNAME="" D
. S DFN=+$G(^TMP($J,"NURCEN",ROOM,BED,PATNAME))
. F REVDT=0:0 S REVDT=$O(^GMR(124.3,"AA",DFN,+GMRGRT,REVDT)) Q:REVDT'>0 F GMRGPDA=0:0 S GMRGPDA=$O(^GMR(124.3,"AA",DFN,+GMRGRT,REVDT,GMRGPDA)) Q:GMRGPDA'>0 D:'+$G(^GMR(124.3,GMRGPDA,5))
. . S NURSCPE=$O(^NURSC(216.8,"B",GMRGPDA,0)) Q:NURSCPE'>0
. . S Y=$P($G(^GMR(124.3,GMRGPDA,0)),U,3),DEVDT=9999999.9999-Y D D^DIQ S NURCPDT(GMRGPDA)=DEVDT_"^"_$E(Y,1,18)
. . S NUREVDT=$$GETPROB^NURCEVE1(NURSCPE,DT) Q:NUREVDT'>0
. . F NURCHC=0:0 S NURCHC=$O(^TMP("NURCHC",$J,NURCHC)) Q:NURCHC'>0 S X=$G(^TMP("NURCHC",$J,NURCHC)) I X'="",$P(X,U,2)'="",+X>0 S ^TMP("NURPROB",$J,DFN,$P(NURCPDT(GMRGPDA),U),+X,GMRGPDA)=X_"^"_$P(NURCPDT(GMRGPDA),U)
. . Q
. Q
U IO
S NURX=0,ROOM="" F S ROOM=$O(^TMP($J,"NURCEN",ROOM)) Q:ROOM=""!NUROUT S BED="" F S BED=$O(^TMP($J,"NURCEN",ROOM,BED)) Q:BED=""!NUROUT S PATNAME="" F S PATNAME=$O(^TMP($J,"NURCEN",ROOM,BED,PATNAME)) Q:PATNAME="" D Q:NUROUT
. S X=$G(^TMP($J,"NURCEN",ROOM,BED,PATNAME)),DFN=+X
. I IOSL-4<$Y!'(NURSW1) D HEADER Q:NUROUT
. W !!,$$PRTRMBD(ROOM,BED),?17,PATNAME," ",$S($P(X,U,2)'="":"("_$P(X,U,2)_")",1:"")
. I $O(^TMP("NURPROB",$J,DFN,""))="" W !?3,"THIS PATIENT HAS NO PROBLEMS TO BE EVALUATED." Q
. S REVDTDV="" F S REVDTDV=$O(^TMP("NURPROB",$J,DFN,REVDTDV)) Q:REVDTDV=""!NUROUT F NURPRB=0:0 S NURPRB=$O(^TMP("NURPROB",$J,DFN,REVDTDV,NURPRB)) Q:NURPRB'>0 D Q:NUROUT
. . F GMRGPDA=0:0 S GMRGPDA=$O(^TMP("NURPROB",$J,DFN,REVDTDV,NURPRB,GMRGPDA)) Q:GMRGPDA'>0 D Q:NUROUT
. . . I IOSL-4<$Y D HEADER Q:NUROUT
. . . S NURX=NURX+1,X1=$G(^TMP("NURPROB",$J,DFN,REVDTDV,NURPRB,GMRGPDA)),GMRGXPRT=$P(X1,U,2),GMRGXPRT(0)=$$SELDAT^NURCEVE2(+X1,GMRGPDA),GMRGXPRT(1)="^^1^^1" D EN1^GMRGRUT2
. . . W !?3,$E(GMRGXPRT,1,43),?48,$P($G(NURCPDT($P(X1,U,4))),U,2),?68,$P(X1,U,3)
. . . Q
. . Q
. Q
W !!
END ; CLEAN UP VARIABLES
K ^TMP($J) F X="NURCHC","NURPROB" K ^TMP(X,$J)
D CLOSE^NURSUT1,^NURCKILL
Q
I NURSW1,$E(IOST)="C" D ENDPG^NURSUT1 S NUROUT=$G(NUROUT) Q:NUROUT
W:$E(IOST)="C"!(PAGE>1) @IOF
S PAGE=PAGE+1,NURSW1=1
W ! S Y=DT D DT^DIQ W ?23,"Nursing Problems to be Evaluated",?70,"Page ",PAGE
W !!,"ROOM/BED",?17,"PATIENT (PID)",!,?48,"DATE/TIME",?68,"EVALUATION",!?3,"PROBLEM TO BE EVALUATED",?48,"DEVELOPED",?68,"DATE"
W !,"=============================================================================="
Q
PRTRMBD(ROOM,BED) ; THIS FUNTION RETURNS THE PRINTABLE FORM OF ROOM/BED
N RMBD
I ROOM'=" BLANK",BED'=" BLANK" S RMBD=ROOM_"-"_BED
E I ROOM=" BLANK",BED=" BLANK" S RMBD=""
E I ROOM=" BLANK" S RMBD="-"_BED
E S RMBD=ROOM_"-"
Q RMBD
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURCEVP0 3688 printed Dec 13, 2024@02:20:32 Page 2
NURCEVP0 ;HIRMFO/RTK,RM,MD-Nursing Care Plans Print Report ;8/29/96
+1 ;;4.0;NURSING SERVICE;;Apr 25, 1997
ENT1 ;
+1 SET GMRGRT=$ORDER(^GMRD(124.2,"AA","NURSC",2,"Nursing Care Plan",""))
IF GMRGRT'>0
WRITE !,$CHAR(7),"THERE IS A PROBLEM IN THE ""AA"" XREF.",!
GOTO END
+2 SET GMRGRT=GMRGRT_"^Nursing Care Plan"
+3 SET NACT=0
DO WARDPAT^NURCUT0
if NURQUIT
GOTO END
DEV ; SELECT DEVICE TO SEND OUTPUT TO.
+1 ; IF REPORT IS QUEUED, SET UP TASK USING %ZTLOAD AND GET OUT OF ROUTINE
+2 SET ZTRTN="PRINT^NURCEVP0"
SET ZTDESC="Nursing Care Plan Print Report"
DO EN7^NURSUT0
KILL ZTDESC,NURQUEUE
IF POP!$DATA(ZTSK)
KILL POP,ZTSK
GOTO END
+3 ;
PRINT ; ENTRY FROM TASKMAN TO PRINT THIS REPORT
+1 SET (PAGE,NURSW1,NUROUT)=0
KILL ^TMP($JOB)
FOR X="NURCHC","NURPROB"
KILL ^TMP(X,$JOB)
+2 ; BUILDS ^TMP($J,"NURCEN",ROOM,BED,PATNAME) ARRAY
DO ^NURCAS2
+3 SET ROOM=""
FOR
SET ROOM=$ORDER(^TMP($JOB,"NURCEN",ROOM))
if ROOM=""
QUIT
SET BED=""
FOR
SET BED=$ORDER(^TMP($JOB,"NURCEN",ROOM,BED))
if BED=""
QUIT
SET PATNAME=""
FOR
SET PATNAME=$ORDER(^TMP($JOB,"NURCEN",ROOM,BED,PATNAME))
if PATNAME=""
QUIT
Begin DoDot:1
+4 SET DFN=+$GET(^TMP($JOB,"NURCEN",ROOM,BED,PATNAME))
+5 FOR REVDT=0:0
SET REVDT=$ORDER(^GMR(124.3,"AA",DFN,+GMRGRT,REVDT))
if REVDT'>0
QUIT
FOR GMRGPDA=0:0
SET GMRGPDA=$ORDER(^GMR(124.3,"AA",DFN,+GMRGRT,REVDT,GMRGPDA))
if GMRGPDA'>0
QUIT
if '+$GET(^GMR(124.3,GMRGPDA,5))
Begin DoDot:2
+6 SET NURSCPE=$ORDER(^NURSC(216.8,"B",GMRGPDA,0))
if NURSCPE'>0
QUIT
+7 SET Y=$PIECE($GET(^GMR(124.3,GMRGPDA,0)),U,3)
SET DEVDT=9999999.9999-Y
DO D^DIQ
SET NURCPDT(GMRGPDA)=DEVDT_"^"_$EXTRACT(Y,1,18)
+8 SET NUREVDT=$$GETPROB^NURCEVE1(NURSCPE,DT)
if NUREVDT'>0
QUIT
+9 FOR NURCHC=0:0
SET NURCHC=$ORDER(^TMP("NURCHC",$JOB,NURCHC))
if NURCHC'>0
QUIT
SET X=$GET(^TMP("NURCHC",$JOB,NURCHC))
IF X'=""
IF $PIECE(X,U,2)'=""
IF +X>0
SET ^TMP("NURPROB",$JOB,DFN,$PIECE(NURCPDT(GMRGPDA),U),+X,GMRGPDA)=X_"^"_$PIECE(NURCPDT(GMRGPDA),U)
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 USE IO
+13 SET NURX=0
SET ROOM=""
FOR
SET ROOM=$ORDER(^TMP($JOB,"NURCEN",ROOM))
if ROOM=""!NUROUT
QUIT
SET BED=""
FOR
SET BED=$ORDER(^TMP($JOB,"NURCEN",ROOM,BED))
if BED=""!NUROUT
QUIT
SET PATNAME=""
FOR
SET PATNAME=$ORDER(^TMP($JOB,"NURCEN",ROOM,BED,PATNAME))
if PATNAME=""
QUIT
Begin DoDot:1
+14 SET X=$GET(^TMP($JOB,"NURCEN",ROOM,BED,PATNAME))
SET DFN=+X
+15 IF IOSL-4<$Y!'(NURSW1)
DO HEADER
if NUROUT
QUIT
+16 WRITE !!,$$PRTRMBD(ROOM,BED),?17,PATNAME," ",$SELECT($PIECE(X,U,2)'="":"("_$PIECE(X,U,2)_")",1:"")
+17 IF $ORDER(^TMP("NURPROB",$JOB,DFN,""))=""
WRITE !?3,"THIS PATIENT HAS NO PROBLEMS TO BE EVALUATED."
QUIT
+18 SET REVDTDV=""
FOR
SET REVDTDV=$ORDER(^TMP("NURPROB",$JOB,DFN,REVDTDV))
if REVDTDV=""!NUROUT
QUIT
FOR NURPRB=0:0
SET NURPRB=$ORDER(^TMP("NURPROB",$JOB,DFN,REVDTDV,NURPRB))
if NURPRB'>0
QUIT
Begin DoDot:2
+19 FOR GMRGPDA=0:0
SET GMRGPDA=$ORDER(^TMP("NURPROB",$JOB,DFN,REVDTDV,NURPRB,GMRGPDA))
if GMRGPDA'>0
QUIT
Begin DoDot:3
+20 IF IOSL-4<$Y
DO HEADER
if NUROUT
QUIT
+21 SET NURX=NURX+1
SET X1=$GET(^TMP("NURPROB",$JOB,DFN,REVDTDV,NURPRB,GMRGPDA))
SET GMRGXPRT=$PIECE(X1,U,2)
SET GMRGXPRT(0)=$$SELDAT^NURCEVE2(+X1,GMRGPDA)
SET GMRGXPRT(1)="^^1^^1"
DO EN1^GMRGRUT2
+22 WRITE !?3,$EXTRACT(GMRGXPRT,1,43),?48,$PIECE($GET(NURCPDT($PIECE(X1,U,4))),U,2),?68,$PIECE(X1,U,3)
+23 QUIT
End DoDot:3
if NUROUT
QUIT
+24 QUIT
End DoDot:2
if NUROUT
QUIT
+25 QUIT
End DoDot:1
if NUROUT
QUIT
+26 WRITE !!
END ; CLEAN UP VARIABLES
+1 KILL ^TMP($JOB)
FOR X="NURCHC","NURPROB"
KILL ^TMP(X,$JOB)
+2 DO CLOSE^NURSUT1
DO ^NURCKILL
+3 QUIT
+1 IF NURSW1
IF $EXTRACT(IOST)="C"
DO ENDPG^NURSUT1
SET NUROUT=$GET(NUROUT)
if NUROUT
QUIT
+2 if $EXTRACT(IOST)="C"!(PAGE>1)
WRITE @IOF
+3 SET PAGE=PAGE+1
SET NURSW1=1
+4 WRITE !
SET Y=DT
DO DT^DIQ
WRITE ?23,"Nursing Problems to be Evaluated",?70,"Page ",PAGE
+5 WRITE !!,"ROOM/BED",?17,"PATIENT (PID)",!,?48,"DATE/TIME",?68,"EVALUATION",!?3,"PROBLEM TO BE EVALUATED",?48,"DEVELOPED",?68,"DATE"
+6 WRITE !,"=============================================================================="
+7 QUIT
PRTRMBD(ROOM,BED) ; THIS FUNTION RETURNS THE PRINTABLE FORM OF ROOM/BED
+1 NEW RMBD
+2 IF ROOM'=" BLANK"
IF BED'=" BLANK"
SET RMBD=ROOM_"-"_BED
+3 IF '$TEST
IF ROOM=" BLANK"
IF BED=" BLANK"
SET RMBD=""
+4 IF '$TEST
IF ROOM=" BLANK"
SET RMBD="-"_BED
+5 IF '$TEST
SET RMBD=ROOM_"-"
+6 QUIT RMBD
