NURCRL4 ;HIRMFO/RM-CARE PLAN RANK ORDER PRINT (cont.) ;8/29/96
;;4.0;NURSING SERVICE;;Apr 25, 1997
PRINT ; ENTRY FROM NURCRL0 TO PRINT THIS REPORT.
;
; Set up required variables for sort.
; Calculate patient census over date/time range.
K ^TMP($J)
D NOW^%DTC S NURCNOW=%,NURCNCP=$O(^GMRD(124.2,"AA","NURSC",2,"Nursing Care Plan",1,0)),NURCINT=$O(^GMRD(124.25,"AA","NURSC","NURSING INTERVENTION",0)),NURCORD=$O(^GMRD(124.25,"AA","NURSC","ORDERABLE",0))
I '$$CENSUS^NURCRL2(NURCBGDT,NURCENDT,NURCNOW,NURCSORT)!'NURCNCP!'NURCINT!'NURCORD U IO S NURCPAGE=$$HEADER^NURCRL1(0) W !!,"There is no data for this report." S NURCPAGE=$$HEADER^NURCRL1(-1) S NURCOUT=1 G EXIT
;
; Loop through ^TMP($J,"NURCEN",DFN) and get DFN to process
; Loop through ^GMR(124.3,"AA",DFN,DATE) over date time range
; BEGIN
F DFN=0:0 S DFN=$O(^TMP($J,"NURCEN",DFN)) Q:DFN'>0 D DEM^VADPT S NURCBS5=$E(VADM(1))_$P($P(VADM(2),"^",2),"-",3) F NURCDATE=(9999999-NURCENDT):0 S NURCDATE=$O(^GMR(124.3,"AA",DFN,NURCNCP,NURCDATE)) Q:NURCDATE'>0 D
.; Get a care plan
.S NURCPDA=$O(^GMR(124.3,"AA",DFN,NURCNCP,NURCDATE,0)) Q:NURCPDA'>0
.; Loop through all entries in SELECTION multiple
.; If ACTIVE(PROBLEM(entry)) THEN
.; BEGIN
.F NURCPDA1=0:0 S NURCPDA1=$O(^GMR(124.3,NURCPDA,1,NURCPDA1)) Q:NURCPDA1'>0 S NURCPTRM=+$G(^GMR(124.3,NURCPDA,1,NURCPDA1,0)) I $$ACTIVE^NURCRL1(NURCPTRM,NURCPDA,NURCBGDT,NURCENDT) D
..; Find frame with CLASSIFICATION=NURSING INTERVENTION that
..; is under this problem.
..S NURCITRM=$$GETTRM^NURCRL1(NURCPTRM,NURCINT)
..; Get list of all frames/terms under NURSING INTERVENTION
..; frame with CLASSIFICATION=ORDERABLE in NURSLIST.
..; If NURSLIST is not empty then Loop through list
..; BEGIN
..I $$GETLST^NURCRL1(NURCITRM,NURCORD) F NURCOTRM=0:0 S NURCOTRM=$O(NURSLIST(NURCOTRM)) Q:NURCOTRM'>0 I $D(^GMR(124.3,NURCPDA,1,"B",NURCOTRM)) D
...; Set up sort arrays for the orderables
...I NURCRTYP=2 D
....K ^TMP($J,"NURSIR",NURCPTRM,9999999-$G(^TMP($J,"NURSORD",NURCPTRM,NURCOTRM)),NURCOTRM)
....S ^TMP($J,"NURSORD",NURCPTRM,NURCOTRM)=$G(^TMP($J,"NURSORD",NURCPTRM,NURCOTRM))+1,^TMP($J,"NURSIR",NURCPTRM,9999999-^TMP($J,"NURSORD",NURCPTRM,NURCOTRM),NURCOTRM)="",^TMP($J,"NURSORD",NURCPTRM,NURCOTRM,NURCBS5)=""
....Q
...I NURCRTYP=3 D
....K ^TMP($J,"NURSIR",9999999-$G(^TMP($J,"NURSORD",NURCOTRM)),NURCOTRM)
....S ^TMP($J,"NURSORD",NURCOTRM)=$G(^TMP($J,"NURSORD",NURCOTRM))+1,^TMP($J,"NURSIR",9999999-^TMP($J,"NURSORD",NURCOTRM),NURCOTRM)="",^TMP($J,"NURSORD",NURCOTRM,NURCBS5)=""
....Q
..; END
..; Set up the sort arrays for the problems
..I NURCRTYP'=3 D
...K ^TMP($J,"NURSPR",9999999-$G(^TMP($J,"NURSPROB",NURCPTRM)),NURCPTRM)
...S ^TMP($J,"NURSPROB",NURCPTRM)=$G(^TMP($J,"NURSPROB",NURCPTRM))+1,^TMP($J,"NURSPR",9999999-^TMP($J,"NURSPROB",NURCPTRM),NURCPTRM)="",^TMP($J,"NURSPROB",NURCPTRM,NURCBS5)=""
...Q
.; END
; END
;
; Set up variables conditioned on report type.
I NURCRTYP'=3 S NURCIPR="NURSPR",NURCPROR="NURSPROB"
E S NURCIPR="NURSIR",NURCPROR="NURSORD"
;
; Use IO
; Print Header
U IO S NURCPAGE=$$HEADER^NURCRL1(0)
I '$D(^TMP($J,NURCIPR)) W !!,"There is no data for this report." S NURCOUT=1 G EXIT
;
; RANK=0
; Loop through ^TMP($J,NURCIPR,FREQ,PROBLEM) increasing RANK with
; each new FREQ
; BEGIN
S (NURCOUT,NURCRANK)=0
F NURCFREQ=0:0 S NURCFREQ=$O(^TMP($J,NURCIPR,NURCFREQ)),NURCRANK=NURCRANK+1 Q:NURCFREQ'>0!NURCOUT F NURCPTRM=0:0 S NURCPTRM=$O(^TMP($J,NURCIPR,NURCFREQ,NURCPTRM)) Q:NURCPTRM'>0!NURCOUT D
.; WRTPROB(RANK,PROBLEM,FREQ)
.; RANK1=0
.; Loop through ^TMP($J,NURCPROR,PROBLEM,BS5)
.; WRTPPT(BS5)
.; If report type is Dx/Int then
.; BEGIN
.; Loop through ^TMP($J,"NURSIR",PR,FREQ1,ORD) increasing
.; RANK1 by one for each new FREQ
.; BEGIN
.S NURCRNK1=0,NURCOUT=$$WRTPROB^NURCRL1(NURCRANK,NURCPTRM,9999999-NURCFREQ) Q:NURCOUT
.W !?15 S NURCBS5="" F S NURCBS5=$O(^TMP($J,NURCPROR,NURCPTRM,NURCBS5)) Q:NURCBS5="" S NURCOUT=$$WRTPPT^NURCRL1(NURCBS5) Q:NURCOUT
.I NURCRTYP=2 D
..S NURCOUT=$$HDRINT^NURCRL1 Q:NURCOUT
..F NURCFRQ1=0:0 S NURCFRQ1=$O(^TMP($J,"NURSIR",NURCPTRM,NURCFRQ1)),NURCRNK1=NURCRNK1+1 Q:NURCFRQ1'>0!NURCOUT F NURCOTRM=0:0 S NURCOTRM=$O(^TMP($J,"NURSIR",NURCPTRM,NURCFRQ1,NURCOTRM)) Q:NURCOTRM'>0!NURCOUT D
...; WRTORD(RANK1,ORD,FREQ1)
...; Loop through ^TMP($J,"NURSORD",PROBLEM,ORD,BS5)
...; WRTOPT(BS5)
...S NURCOUT=$$WRTORD^NURCRL1(NURCRNK1,NURCOTRM,9999999-NURCFRQ1) Q:NURCOUT
...W !?20 S NURCBS5="" F S NURCBS5=$O(^TMP($J,"NURSORD",NURCPTRM,NURCOTRM,NURCBS5)) Q:NURCBS5="" S NURCOUT=$$WRTOPT^NURCRL1(NURCBS5) Q:NURCOUT
..; END
.; END
; END
EXIT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURCRL4 4926 printed Dec 13, 2024@02:20:53 Page 2
NURCRL4 ;HIRMFO/RM-CARE PLAN RANK ORDER PRINT (cont.) ;8/29/96
+1 ;;4.0;NURSING SERVICE;;Apr 25, 1997
PRINT ; ENTRY FROM NURCRL0 TO PRINT THIS REPORT.
+1 ;
+2 ; Set up required variables for sort.
+3 ; Calculate patient census over date/time range.
+4 KILL ^TMP($JOB)
+5 DO NOW^%DTC
SET NURCNOW=%
SET NURCNCP=$ORDER(^GMRD(124.2,"AA","NURSC",2,"Nursing Care Plan",1,0))
SET NURCINT=$ORDER(^GMRD(124.25,"AA","NURSC","NURSING INTERVENTION",0))
SET NURCORD=$ORDER(^GMRD(124.25,"AA","NURSC","ORDERABLE",0))
+6 IF '$$CENSUS^NURCRL2(NURCBGDT,NURCENDT,NURCNOW,NURCSORT)!'NURCNCP!'NURCINT!'NURCORD
USE IO
SET NURCPAGE=$$HEADER^NURCRL1(0)
WRITE !!,"There is no data for this report."
SET NURCPAGE=$$HEADER^NURCRL1(-1)
SET NURCOUT=1
GOTO EXIT
+7 ;
+8 ; Loop through ^TMP($J,"NURCEN",DFN) and get DFN to process
+9 ; Loop through ^GMR(124.3,"AA",DFN,DATE) over date time range
+10 ; BEGIN
+11 FOR DFN=0:0
SET DFN=$ORDER(^TMP($JOB,"NURCEN",DFN))
if DFN'>0
QUIT
DO DEM^VADPT
SET NURCBS5=$EXTRACT(VADM(1))_$PIECE($PIECE(VADM(2),"^",2),"-",3)
FOR NURCDATE=(9999999-NURCENDT):0
SET NURCDATE=$ORDER(^GMR(124.3,"AA",DFN,NURCNCP,NURCDATE))
if NURCDATE'>0
QUIT
Begin DoDot:1
+12 ; Get a care plan
+13 SET NURCPDA=$ORDER(^GMR(124.3,"AA",DFN,NURCNCP,NURCDATE,0))
if NURCPDA'>0
QUIT
+14 ; Loop through all entries in SELECTION multiple
+15 ; If ACTIVE(PROBLEM(entry)) THEN
+16 ; BEGIN
+17 FOR NURCPDA1=0:0
SET NURCPDA1=$ORDER(^GMR(124.3,NURCPDA,1,NURCPDA1))
if NURCPDA1'>0
QUIT
SET NURCPTRM=+$GET(^GMR(124.3,NURCPDA,1,NURCPDA1,0))
IF $$ACTIVE^NURCRL1(NURCPTRM,NURCPDA,NURCBGDT,NURCENDT)
Begin DoDot:2
+18 ; Find frame with CLASSIFICATION=NURSING INTERVENTION that
+19 ; is under this problem.
+20 SET NURCITRM=$$GETTRM^NURCRL1(NURCPTRM,NURCINT)
+21 ; Get list of all frames/terms under NURSING INTERVENTION
+22 ; frame with CLASSIFICATION=ORDERABLE in NURSLIST.
+23 ; If NURSLIST is not empty then Loop through list
+24 ; BEGIN
+25 IF $$GETLST^NURCRL1(NURCITRM,NURCORD)
FOR NURCOTRM=0:0
SET NURCOTRM=$ORDER(NURSLIST(NURCOTRM))
if NURCOTRM'>0
QUIT
IF $DATA(^GMR(124.3,NURCPDA,1,"B",NURCOTRM))
Begin DoDot:3
+26 ; Set up sort arrays for the orderables
+27 IF NURCRTYP=2
Begin DoDot:4
+28 KILL ^TMP($JOB,"NURSIR",NURCPTRM,9999999-$GET(^TMP($JOB,"NURSORD",NURCPTRM,NURCOTRM)),NURCOTRM)
+29 SET ^TMP($JOB,"NURSORD",NURCPTRM,NURCOTRM)=$GET(^TMP($JOB,"NURSORD",NURCPTRM,NURCOTRM))+1
SET ^TMP($JOB,"NURSIR",NURCPTRM,9999999-^TMP($JOB,"NURSORD",NURCPTRM,NURCOTRM),NURCOTRM)=""
SET ^TMP($JOB,"NURSORD",NURCPTRM,NURCOTRM,NURCBS5)=""
+30 QUIT
End DoDot:4
+31 IF NURCRTYP=3
Begin DoDot:4
+32 KILL ^TMP($JOB,"NURSIR",9999999-$GET(^TMP($JOB,"NURSORD",NURCOTRM)),NURCOTRM)
+33 SET ^TMP($JOB,"NURSORD",NURCOTRM)=$GET(^TMP($JOB,"NURSORD",NURCOTRM))+1
SET ^TMP($JOB,"NURSIR",9999999-^TMP($JOB,"NURSORD",NURCOTRM),NURCOTRM)=""
SET ^TMP($JOB,"NURSORD",NURCOTRM,NURCBS5)=""
+34 QUIT
End DoDot:4
End DoDot:3
+35 ; END
+36 ; Set up the sort arrays for the problems
+37 IF NURCRTYP'=3
Begin DoDot:3
+38 KILL ^TMP($JOB,"NURSPR",9999999-$GET(^TMP($JOB,"NURSPROB",NURCPTRM)),NURCPTRM)
+39 SET ^TMP($JOB,"NURSPROB",NURCPTRM)=$GET(^TMP($JOB,"NURSPROB",NURCPTRM))+1
SET ^TMP($JOB,"NURSPR",9999999-^TMP($JOB,"NURSPROB",NURCPTRM),NURCPTRM)=""
SET ^TMP($JOB,"NURSPROB",NURCPTRM,NURCBS5)=""
+40 QUIT
End DoDot:3
End DoDot:2
+41 ; END
End DoDot:1
+42 ; END
+43 ;
+44 ; Set up variables conditioned on report type.
+45 IF NURCRTYP'=3
SET NURCIPR="NURSPR"
SET NURCPROR="NURSPROB"
+46 IF '$TEST
SET NURCIPR="NURSIR"
SET NURCPROR="NURSORD"
+47 ;
+48 ; Use IO
+49 ; Print Header
+50 USE IO
SET NURCPAGE=$$HEADER^NURCRL1(0)
+51 IF '$DATA(^TMP($JOB,NURCIPR))
WRITE !!,"There is no data for this report."
SET NURCOUT=1
GOTO EXIT
+52 ;
+53 ; RANK=0
+54 ; Loop through ^TMP($J,NURCIPR,FREQ,PROBLEM) increasing RANK with
+55 ; each new FREQ
+56 ; BEGIN
+57 SET (NURCOUT,NURCRANK)=0
+58 FOR NURCFREQ=0:0
SET NURCFREQ=$ORDER(^TMP($JOB,NURCIPR,NURCFREQ))
SET NURCRANK=NURCRANK+1
if NURCFREQ'>0!NURCOUT
QUIT
FOR NURCPTRM=0:0
SET NURCPTRM=$ORDER(^TMP($JOB,NURCIPR,NURCFREQ,NURCPTRM))
if NURCPTRM'>0!NURCOUT
QUIT
Begin DoDot:1
+59 ; WRTPROB(RANK,PROBLEM,FREQ)
+60 ; RANK1=0
+61 ; Loop through ^TMP($J,NURCPROR,PROBLEM,BS5)
+62 ; WRTPPT(BS5)
+63 ; If report type is Dx/Int then
+64 ; BEGIN
+65 ; Loop through ^TMP($J,"NURSIR",PR,FREQ1,ORD) increasing
+66 ; RANK1 by one for each new FREQ
+67 ; BEGIN
+68 SET NURCRNK1=0
SET NURCOUT=$$WRTPROB^NURCRL1(NURCRANK,NURCPTRM,9999999-NURCFREQ)
if NURCOUT
QUIT
+69 WRITE !?15
SET NURCBS5=""
FOR
SET NURCBS5=$ORDER(^TMP($JOB,NURCPROR,NURCPTRM,NURCBS5))
if NURCBS5=""
QUIT
SET NURCOUT=$$WRTPPT^NURCRL1(NURCBS5)
if NURCOUT
QUIT
+70 IF NURCRTYP=2
Begin DoDot:2
+71 SET NURCOUT=$$HDRINT^NURCRL1
if NURCOUT
QUIT
+72 FOR NURCFRQ1=0:0
SET NURCFRQ1=$ORDER(^TMP($JOB,"NURSIR",NURCPTRM,NURCFRQ1))
SET NURCRNK1=NURCRNK1+1
if NURCFRQ1'>0!NURCOUT
QUIT
FOR NURCOTRM=0:0
SET NURCOTRM=$ORDER(^TMP($JOB,"NURSIR",NURCPTRM,NURCFRQ1,NURCOTRM))
if NURCOTRM'>0!NURCOUT
QUIT
Begin DoDot:3
+73 ; WRTORD(RANK1,ORD,FREQ1)
+74 ; Loop through ^TMP($J,"NURSORD",PROBLEM,ORD,BS5)
+75 ; WRTOPT(BS5)
+76 SET NURCOUT=$$WRTORD^NURCRL1(NURCRNK1,NURCOTRM,9999999-NURCFRQ1)
if NURCOUT
QUIT
+77 WRITE !?20
SET NURCBS5=""
FOR
SET NURCBS5=$ORDER(^TMP($JOB,"NURSORD",NURCPTRM,NURCOTRM,NURCBS5))
if NURCBS5=""
QUIT
SET NURCOUT=$$WRTOPT^NURCRL1(NURCBS5)
if NURCOUT
QUIT
End DoDot:3
+78 ; END
End DoDot:2
+79 ; END
End DoDot:1
+80 ; END
EXIT QUIT
