NURCRL1 ;HIRMFO/RM,RTK-RANK ORDER PRINT (CONT.) ;8/29/96
;;4.0;NURSING SERVICE;;Apr 25, 1997
;;
; FUNCTION VALUE IS THE NUMBER OF NEW PAGE, -1 IF ABNORMAL USER EXIT
N DIR,X,Y I PG,$E(IOST)="C" W ! S DIR(0)="E" D ^DIR I 'Y S PG=-1 G RETURN
I PG'<0 D
. S PG=PG+1
. W:$E(IOST)="C"!(PG>1) @IOF W !,"RANK LISTING OF "_$S(NURCRTYP=1:"NURSING PROBLEMS",NURCRTYP=2:"NURSING PROBLEMS/INTERVENTIONS",1:"NURSING INTERVENTIONS"),?71,"PAGE",$J(PG,3)
. S Y=NURCBGDT\1 D DD^%DT W !,"From: ",Y S Y=NURCENDT\1 D DD^%DT W " to: ",Y
. W !!,"Rank Freq Problem" I NURCLID'="" W " Report Identifier: ",NURCLID
. W !,"=============================================================================="
. Q
RETURN Q PG
HDRINT() ; PRINTS HEADER FOR INTERVENTIONS UNDER A PROBLEM
; FUNCTION VALUE IS 1 IF ABNORMAL USER END, ELSE 0
N WRT S WRT=1 I IOSL-8<$Y S NURCPAGE=$$HEADER(NURCPAGE) I NURCPAGE<0 S WRT=0
I WRT W !?5,"Rank Freq Intervention",!?5,"---- ---- ------------"
Q 'WRT
WRTPROB(RANK,PROB,FREQ) ; WRITES OUT LINE FOR PROBLEM, CHECKS FOR HEADER PRINT
; FUNCTION VALUE IS 1 IF ABNORMAL USER END, ELSE 0
N WRT S WRT=1 I IOSL-7<$Y S NURCPAGE=$$HEADER(NURCPAGE) I NURCPAGE<0 S WRT=0
I WRT W !!,$J(RANK,3),?5,$J(FREQ,4),?11,$P($G(^GMRD(124.2,+PROB,0)),"^")
Q 'WRT
WRTORD(RANK,ORD,FREQ) ; WRITES OUT LINE FOR ORDERABLE, CHECKS FOR HDR PRINT
; FUNCTION VALUE IS 1 IF ABNORMAL USER EXIT, ELSE 0
N WRT S WRT=1 I IOSL-6<$Y S NURCPAGE=$$HEADER(NURCPAGE) I NURCPAGE<0 S WRT=0
I WRT W !?5,$J(RANK,3),?10,$J(FREQ,4),?16,$P($G(^GMRD(124.2,+ORD,0)),"^")
Q 'WRT
WRTOPT(BS5) ; WRITES OUT LINE FOR PATIENTS UNDER ORDERABLE, CHECKS FOR HDR
; FUNCTION VALUE IS 1 IF ABNORMAL USER END, ELSE 0
N WRT S WRT=1 I IOM-8<$X S:IOSL-6<$Y NURCPAGE=$$HEADER(NURCPAGE) S:NURCPAGE<0 WRT=0 W:WRT !?20
I WRT W BS5,","
Q 'WRT
WRTPPT(BS5) ; WRITES OUT LINE FOR PATIENTS UNDER PROBLEM, CHECKS FOR HDR
; FUNCTION VALUE IS 1 IF ABNORMAL USER END, ELSE 0
N WRT S WRT=1 I IOM-8<$X S:IOSL-6<$Y NURCPAGE=$$HEADER(NURCPAGE) S:NURCPAGE<0 WRT=0 W:WRT !?15
I WRT W BS5,","
Q 'WRT
ACTIVE(PR,NCP,BDT,EDT) ;
; FUNCTION VALUE IS 0 IF THIS PROBLEM IS ACTIVE OVER DATE/TIME RANGE
; BGD-EDT, ELSE VALUE IS 1
N ACTIVE,NNCP,X,Y S ACTIVE=1
S NNCP=$O(^NURSC(216.8,"B",NCP,0)) S:NNCP'>0!'$$PROBLEM(PR) ACTIVE=0
I ACTIVE S ACTIVE=0 F X=(9999999-EDT):0 S X=$O(^NURSC(216.8,NNCP,"EVAL","AA",PR,X)) Q:X'>0 S Y=$O(^NURSC(216.8,NNCP,"EVAL","AA",PR,X,0)) I Y S Y=$G(^NURSC(216.8,NNCP,"EVAL",Y,0)) S ACTIVE='(+Y<BDT&$P(Y,"^",4)) Q
Q ACTIVE
PROBLEM(AGGY) ;
; FUNCTION VALUE IS 1 IF AGGY HAS CLASS OF NURSING PROBLEM, ELSE
; RETURNS 0.
N CLAS,PROBLEM S PROBLEM=1
S CLAS=$O(^GMRD(124.25,"AA","NURSC","NURSING PROBLEM",0)) S:'CLAS PROBLEM=0
I PROBLEM S PROBLEM=($P($G(^GMRD(124.2,AGGY,0)),"^",4)=CLAS)
Q PROBLEM
GETTRM(PR,CLAS) ;
; GETS FIRST TERM ENCOUNTERED IN TREE WITH PR AS ROOT WITH CLASS.=CLAS
N A,B,C,D,E
S A=PR,E=0 D RECUR1
Q E
RECUR1 N D,B F B=0:0 S B=$O(^GMRD(124.2,A,1,B)) Q:B'>0 S C=+$G(^GMRD(124.2,A,1,B,0)) I '$P(C,"^",6),+C S D=$G(^GMRD(124.2,C,0)) S:$P(D,"^",4)=CLAS E=C Q:E S D=A,A=C D RECUR1 S A=D Q:E
Q
GETLST(PR,CLAS) ; GETS LIST OF TERMS IN TREE WITH PR AS ROOT WITH CLASS.=CLAS
; FUNCTION RETURNS 1 IF LIST NOT EMPTY, ELSE RETURNS 0.
N A,B,C,D K NURSLIST
S A=PR D RECUR
Q ''$D(NURSLIST)
RECUR N D,B F B=0:0 S B=$O(^GMRD(124.2,A,1,B)) Q:B'>0 S C=+$G(^GMRD(124.2,A,1,B,0)) I '$P(C,"^",6),+C S D=$G(^GMRD(124.2,C,0)) S:$P(D,"^",4)=CLAS NURSLIST(C)="" S D=A,A=C D RECUR S A=D
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURCRL1 3603 printed Oct 16, 2024@18:21:35 Page 2
NURCRL1 ;HIRMFO/RM,RTK-RANK ORDER PRINT (CONT.) ;8/29/96
+1 ;;4.0;NURSING SERVICE;;Apr 25, 1997
+2 ;;
+1 ; FUNCTION VALUE IS THE NUMBER OF NEW PAGE, -1 IF ABNORMAL USER EXIT
+2 NEW DIR,X,Y
IF PG
IF $EXTRACT(IOST)="C"
WRITE !
SET DIR(0)="E"
DO ^DIR
IF 'Y
SET PG=-1
GOTO RETURN
+3 IF PG'<0
Begin DoDot:1
+4 SET PG=PG+1
+5 if $EXTRACT(IOST)="C"!(PG>1)
WRITE @IOF
WRITE !,"RANK LISTING OF "_$SELECT(NURCRTYP=1:"NURSING PROBLEMS",NURCRTYP=2:"NURSING PROBLEMS/INTERVENTIONS",1:"NURSING INTERVENTIONS"),?71,"PAGE",$JUSTIFY(PG,3)
+6 SET Y=NURCBGDT\1
DO DD^%DT
WRITE !,"From: ",Y
SET Y=NURCENDT\1
DO DD^%DT
WRITE " to: ",Y
+7 WRITE !!,"Rank Freq Problem"
IF NURCLID'=""
WRITE " Report Identifier: ",NURCLID
+8 WRITE !,"=============================================================================="
+9 QUIT
End DoDot:1
RETURN QUIT PG
HDRINT() ; PRINTS HEADER FOR INTERVENTIONS UNDER A PROBLEM
+1 ; FUNCTION VALUE IS 1 IF ABNORMAL USER END, ELSE 0
+2 NEW WRT
SET WRT=1
IF IOSL-8<$Y
SET NURCPAGE=$$HEADER(NURCPAGE)
IF NURCPAGE<0
SET WRT=0
+3 IF WRT
WRITE !?5,"Rank Freq Intervention",!?5,"---- ---- ------------"
+4 QUIT 'WRT
WRTPROB(RANK,PROB,FREQ) ; WRITES OUT LINE FOR PROBLEM, CHECKS FOR HEADER PRINT
+1 ; FUNCTION VALUE IS 1 IF ABNORMAL USER END, ELSE 0
+2 NEW WRT
SET WRT=1
IF IOSL-7<$Y
SET NURCPAGE=$$HEADER(NURCPAGE)
IF NURCPAGE<0
SET WRT=0
+3 IF WRT
WRITE !!,$JUSTIFY(RANK,3),?5,$JUSTIFY(FREQ,4),?11,$PIECE($GET(^GMRD(124.2,+PROB,0)),"^")
+4 QUIT 'WRT
WRTORD(RANK,ORD,FREQ) ; WRITES OUT LINE FOR ORDERABLE, CHECKS FOR HDR PRINT
+1 ; FUNCTION VALUE IS 1 IF ABNORMAL USER EXIT, ELSE 0
+2 NEW WRT
SET WRT=1
IF IOSL-6<$Y
SET NURCPAGE=$$HEADER(NURCPAGE)
IF NURCPAGE<0
SET WRT=0
+3 IF WRT
WRITE !?5,$JUSTIFY(RANK,3),?10,$JUSTIFY(FREQ,4),?16,$PIECE($GET(^GMRD(124.2,+ORD,0)),"^")
+4 QUIT 'WRT
WRTOPT(BS5) ; WRITES OUT LINE FOR PATIENTS UNDER ORDERABLE, CHECKS FOR HDR
+1 ; FUNCTION VALUE IS 1 IF ABNORMAL USER END, ELSE 0
+2 NEW WRT
SET WRT=1
IF IOM-8<$X
if IOSL-6<$Y
SET NURCPAGE=$$HEADER(NURCPAGE)
if NURCPAGE<0
SET WRT=0
if WRT
WRITE !?20
+3 IF WRT
WRITE BS5,","
+4 QUIT 'WRT
WRTPPT(BS5) ; WRITES OUT LINE FOR PATIENTS UNDER PROBLEM, CHECKS FOR HDR
+1 ; FUNCTION VALUE IS 1 IF ABNORMAL USER END, ELSE 0
+2 NEW WRT
SET WRT=1
IF IOM-8<$X
if IOSL-6<$Y
SET NURCPAGE=$$HEADER(NURCPAGE)
if NURCPAGE<0
SET WRT=0
if WRT
WRITE !?15
+3 IF WRT
WRITE BS5,","
+4 QUIT 'WRT
ACTIVE(PR,NCP,BDT,EDT) ;
+1 ; FUNCTION VALUE IS 0 IF THIS PROBLEM IS ACTIVE OVER DATE/TIME RANGE
+2 ; BGD-EDT, ELSE VALUE IS 1
+3 NEW ACTIVE,NNCP,X,Y
SET ACTIVE=1
+4 SET NNCP=$ORDER(^NURSC(216.8,"B",NCP,0))
if NNCP'>0!'$$PROBLEM(PR)
SET ACTIVE=0
+5 IF ACTIVE
SET ACTIVE=0
FOR X=(9999999-EDT):0
SET X=$ORDER(^NURSC(216.8,NNCP,"EVAL","AA",PR,X))
if X'>0
QUIT
SET Y=$ORDER(^NURSC(216.8,NNCP,"EVAL","AA",PR,X,0))
IF Y
SET Y=$GET(^NURSC(216.8,NNCP,"EVAL",Y,0))
SET ACTIVE='(+Y<BDT&$PIECE(Y,"^",4))
QUIT
+6 QUIT ACTIVE
PROBLEM(AGGY) ;
+1 ; FUNCTION VALUE IS 1 IF AGGY HAS CLASS OF NURSING PROBLEM, ELSE
+2 ; RETURNS 0.
+3 NEW CLAS,PROBLEM
SET PROBLEM=1
+4 SET CLAS=$ORDER(^GMRD(124.25,"AA","NURSC","NURSING PROBLEM",0))
if 'CLAS
SET PROBLEM=0
+5 IF PROBLEM
SET PROBLEM=($PIECE($GET(^GMRD(124.2,AGGY,0)),"^",4)=CLAS)
+6 QUIT PROBLEM
GETTRM(PR,CLAS) ;
+1 ; GETS FIRST TERM ENCOUNTERED IN TREE WITH PR AS ROOT WITH CLASS.=CLAS
+2 NEW A,B,C,D,E
+3 SET A=PR
SET E=0
DO RECUR1
+4 QUIT E
RECUR1 NEW D,B
FOR B=0:0
SET B=$ORDER(^GMRD(124.2,A,1,B))
if B'>0
QUIT
SET C=+$GET(^GMRD(124.2,A,1,B,0))
IF '$PIECE(C,"^",6)
IF +C
SET D=$GET(^GMRD(124.2,C,0))
if $PIECE(D,"^",4)=CLAS
SET E=C
if E
QUIT
SET D=A
SET A=C
DO RECUR1
SET A=D
if E
QUIT
+1 QUIT
GETLST(PR,CLAS) ; GETS LIST OF TERMS IN TREE WITH PR AS ROOT WITH CLASS.=CLAS
+1 ; FUNCTION RETURNS 1 IF LIST NOT EMPTY, ELSE RETURNS 0.
+2 NEW A,B,C,D
KILL NURSLIST
+3 SET A=PR
DO RECUR
+4 QUIT ''$DATA(NURSLIST)
RECUR NEW D,B
FOR B=0:0
SET B=$ORDER(^GMRD(124.2,A,1,B))
if B'>0
QUIT
SET C=+$GET(^GMRD(124.2,A,1,B,0))
IF '$PIECE(C,"^",6)
IF +C
SET D=$GET(^GMRD(124.2,C,0))
if $PIECE(D,"^",4)=CLAS
SET NURSLIST(C)=""
SET D=A
SET A=C
DO RECUR
SET A=D
+1 QUIT
