- 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 Mar 13, 2025@21:25:56 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
