source: FOIAVistA/trunk/r/NURSING_SERVICE-NUR/NURCRL4.m@ 1250

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