- NURCROP1 ;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>0,$E(IOST)="C" W ! D ENDPG^NURSUT1 I $G(NUROUT) S PG=-1 G RETURN
- W:$E(IOST)="C"!(PG>1) @IOF
- S PG=PG+1 W !,"RANK LISTING OF PATIENT PROBLEMS",?71,"PAGE",$J(PG,3)
- I PG'<0 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
- I PG'<0 W !,"=============================================================================="
- 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
- NURCROP1 ;HIRMFO/RM,RTK-RANK ORDER PRINT (CONT.) ;8/29/96
- +1 ;;4.0;NURSING SERVICE;;Apr 25, 1997
- +1 ; FUNCTION VALUE IS THE NUMBER OF NEW PAGE, -1 IF ABNORMAL USER EXIT
- +2 NEW DIR,X,Y
- IF PG>0
- IF $EXTRACT(IOST)="C"
- WRITE !
- DO ENDPG^NURSUT1
- IF $GET(NUROUT)
- SET PG=-1
- GOTO RETURN
- +3 IF $EXTRACT(IOST)="C"!(PG>1)
- WRITE @IOF
- +4 SET PG=PG+1
- WRITE !,"RANK LISTING OF PATIENT PROBLEMS",?71,"PAGE",$JUSTIFY(PG,3)
- +5 IF PG'<0
- SET Y=NURCBGDT\1
- DO DD^%DT
- WRITE !,"From: ",Y
- SET Y=NURCENDT\1
- DO DD^%DT
- WRITE " to: ",Y
- WRITE !!,"Rank Freq Problem"
- IF NURCLID'=""
- WRITE " Report Identifier: ",NURCLID
- +6 IF PG'<0
- WRITE !,"=============================================================================="
- 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
