- PRCPRGRU ;WISC/RFJ-get graph in variable ;09 Feb 94
- ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- Q
- ;
- ;
- GETGRAPH(HEADING,YHEADING,XHEADING,XCODE,BARCHART,AVGFZERO,DATA) ;
- ; return graph in variable yline
- ; heading=top of graph
- ; yheading=yaxis heading
- ; xheading=xaxis heading
- ; xcode=mumps code to set label on xaxis
- ; barchart=1 for barchart
- ; avgfzero=1 to include zero values when calculating the average
- ; data(xaxis)=value
- ;
- N %,AVERAGE,AVGCOUNT,AVGFLAG,AVGLINE,CHAR,COLUMN,COUNT,DATALINE,FRONT,INCREMEN,LASTLINE,LINE,MAXVALUE,SPACE,STEP,TOTAL,TOTLENGT,TOTVALUE,VALUE,X,XAXIS,Y
- S SPACE=" "
- S YHEADING=YHEADING_SPACE
- S MAXVALUE=0,TOTVALUE=0,AVGCOUNT=0
- S X="" F TOTAL=1:1 S X=$O(DATA(X)) Q:X="" S COLUMN(TOTAL*5)=DATA(X)_"*^",TOTVALUE=TOTVALUE+DATA(X) S AVGCOUNT=$S('AVGFZERO&('DATA(X)):AVGCOUNT,1:AVGCOUNT+1) I DATA(X)>MAXVALUE S MAXVALUE=DATA(X)
- S AVERAGE="0.00" I AVGCOUNT S AVERAGE=$J(TOTVALUE/AVGCOUNT,0,2)
- S LASTLINE="",$P(LASTLINE,"+----",TOTAL+1)=""
- S INCREMEN=$J(MAXVALUE/6,0,2) I +INCREMEN=0 S INCREMEN=1
- ; build array in yline
- S YLINE(1)=" ^ "_HEADING
- S YLINE(2)=" |"_$E(SPACE,1,69)
- S COUNT=2
- F LINE=6:-1:1 D
- . D SETLINE(LINE)
- . S FRONT=$E(YHEADING,COUNT-1)_$E($J(INCREMEN*LINE,7),1,7)_"-+"
- . S COUNT=COUNT+1,YLINE(COUNT)=FRONT_$E(DATALINE,1,79)
- . D SETLINE(LINE-.5)
- . S FRONT=$E(YHEADING,COUNT-1)_" |"
- . S COUNT=COUNT+1,YLINE(COUNT)=FRONT_$E(DATALINE,1,79)
- S YLINE(COUNT)=$E(YLINE(COUNT),1,9)_LASTLINE_">",TOTLENGT=$L(YLINE(COUNT))
- S COUNT=COUNT+1,YLINE(COUNT)=$E($E(XHEADING,1,10)_SPACE,1,10)
- S YLINE(COUNT+1)=$E($E(XHEADING,11,20)_SPACE,1,10)
- S XAXIS="" F S XAXIS=$O(DATA(XAXIS)) Q:XAXIS="" S X=XAXIS K X(1) X:XCODE'="" XCODE S YLINE(COUNT)=YLINE(COUNT)_$E($J(X,5),1,5) I $D(X(1)) S YLINE(COUNT+1)=YLINE(COUNT+1)_$E($J(X(1),5),1,5)
- I $TR($G(YLINE(COUNT+1))," ")'="" S COUNT=COUNT+1
- S COUNT=COUNT+1,YLINE(COUNT)=" AVERAGE: "_AVERAGE
- I $G(AVGLINE) S YLINE(AVGLINE)=$E(YLINE(AVGLINE),1,10)_$E($TR($E(YLINE(AVGLINE),11,255)," -|^","===="),1,TOTLENGT-15)_" AVG"
- ; remove trailing spaces
- S X=0 F S X=$O(YLINE(X)) Q:'X D
- . F %=$L(YLINE(X)):-1,10 Q:$E(YLINE(X),%)'=" "
- . S YLINE(X)=$E(YLINE(X),1,%)
- Q
- ;
- ;
- SETLINE(STEP) ; build line of display
- ; step=incerment on y-axis
- S DATALINE=$E(SPACE,1,69)
- F %=5:5 Q:'$D(COLUMN(%)) S VALUE=+COLUMN(%),CHAR=$P(COLUMN(%),"*",2) I VALUE'<(INCREMEN*STEP) D
- . ; set value on top of previous line
- . I CHAR="^" S X=$S($G(BARCHART):8,1:9),Y=X-1+%+$L(VALUE),YLINE(COUNT)=$E(YLINE(COUNT),0,X+%-1)_VALUE_$E(YLINE(COUNT),Y+1,200)
- . S X=" "_CHAR I $G(BARCHART),CHAR="^" S X="-----"
- . I $G(BARCHART),$E(DATALINE,%-5)=" " S DATALINE=$E(DATALINE,0,%-6)_$S(X["-":"-",1:"|")_$E(DATALINE,%-4,200)
- . S DATALINE=$E(DATALINE,0,%-5)_X_$E(DATALINE,%-3,200),$P(COLUMN(%),"*",2)="|"
- I AVERAGE'<(INCREMEN*STEP),'$G(AVGFLAG) S AVGFLAG=1,AVGLINE=COUNT+1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRGRU 3142 printed Feb 18, 2025@23:41:16 Page 2
- PRCPRGRU ;WISC/RFJ-get graph in variable ;09 Feb 94
- +1 ;;5.1;IFCAP;;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 QUIT
- +4 ;
- +5 ;
- GETGRAPH(HEADING,YHEADING,XHEADING,XCODE,BARCHART,AVGFZERO,DATA) ;
- +1 ; return graph in variable yline
- +2 ; heading=top of graph
- +3 ; yheading=yaxis heading
- +4 ; xheading=xaxis heading
- +5 ; xcode=mumps code to set label on xaxis
- +6 ; barchart=1 for barchart
- +7 ; avgfzero=1 to include zero values when calculating the average
- +8 ; data(xaxis)=value
- +9 ;
- +10 NEW %,AVERAGE,AVGCOUNT,AVGFLAG,AVGLINE,CHAR,COLUMN,COUNT,DATALINE,FRONT,INCREMEN,LASTLINE,LINE,MAXVALUE,SPACE,STEP,TOTAL,TOTLENGT,TOTVALUE,VALUE,X,XAXIS,Y
- +11 SET SPACE=" "
- +12 SET YHEADING=YHEADING_SPACE
- +13 SET MAXVALUE=0
- SET TOTVALUE=0
- SET AVGCOUNT=0
- +14 SET X=""
- FOR TOTAL=1:1
- SET X=$ORDER(DATA(X))
- if X=""
- QUIT
- SET COLUMN(TOTAL*5)=DATA(X)_"*^"
- SET TOTVALUE=TOTVALUE+DATA(X)
- SET AVGCOUNT=$SELECT('AVGFZERO&('DATA(X)):AVGCOUNT,1:AVGCOUNT+1)
- IF DATA(X)>MAXVALUE
- SET MAXVALUE=DATA(X)
- +15 SET AVERAGE="0.00"
- IF AVGCOUNT
- SET AVERAGE=$JUSTIFY(TOTVALUE/AVGCOUNT,0,2)
- +16 SET LASTLINE=""
- SET $PIECE(LASTLINE,"+----",TOTAL+1)=""
- +17 SET INCREMEN=$JUSTIFY(MAXVALUE/6,0,2)
- IF +INCREMEN=0
- SET INCREMEN=1
- +18 ; build array in yline
- +19 SET YLINE(1)=" ^ "_HEADING
- +20 SET YLINE(2)=" |"_$EXTRACT(SPACE,1,69)
- +21 SET COUNT=2
- +22 FOR LINE=6:-1:1
- Begin DoDot:1
- +23 DO SETLINE(LINE)
- +24 SET FRONT=$EXTRACT(YHEADING,COUNT-1)_$EXTRACT($JUSTIFY(INCREMEN*LINE,7),1,7)_"-+"
- +25 SET COUNT=COUNT+1
- SET YLINE(COUNT)=FRONT_$EXTRACT(DATALINE,1,79)
- +26 DO SETLINE(LINE-.5)
- +27 SET FRONT=$EXTRACT(YHEADING,COUNT-1)_" |"
- +28 SET COUNT=COUNT+1
- SET YLINE(COUNT)=FRONT_$EXTRACT(DATALINE,1,79)
- End DoDot:1
- +29 SET YLINE(COUNT)=$EXTRACT(YLINE(COUNT),1,9)_LASTLINE_">"
- SET TOTLENGT=$LENGTH(YLINE(COUNT))
- +30 SET COUNT=COUNT+1
- SET YLINE(COUNT)=$EXTRACT($EXTRACT(XHEADING,1,10)_SPACE,1,10)
- +31 SET YLINE(COUNT+1)=$EXTRACT($EXTRACT(XHEADING,11,20)_SPACE,1,10)
- +32 SET XAXIS=""
- FOR
- SET XAXIS=$ORDER(DATA(XAXIS))
- if XAXIS=""
- QUIT
- SET X=XAXIS
- KILL X(1)
- if XCODE'=""
- XECUTE XCODE
- SET YLINE(COUNT)=YLINE(COUNT)_$EXTRACT($JUSTIFY(X,5),1,5)
- IF $DATA(X(1))
- SET YLINE(COUNT+1)=YLINE(COUNT+1)_$EXTRACT($JUSTIFY(X(1),5),1,5)
- +33 IF $TRANSLATE($GET(YLINE(COUNT+1))," ")'=""
- SET COUNT=COUNT+1
- +34 SET COUNT=COUNT+1
- SET YLINE(COUNT)=" AVERAGE: "_AVERAGE
- +35 IF $GET(AVGLINE)
- SET YLINE(AVGLINE)=$EXTRACT(YLINE(AVGLINE),1,10)_$EXTRACT($TRANSLATE($EXTRACT(YLINE(AVGLINE),11,255)," -|^","===="),1,TOTLENGT-15)_" AVG"
- +36 ; remove trailing spaces
- +37 SET X=0
- FOR
- SET X=$ORDER(YLINE(X))
- if 'X
- QUIT
- Begin DoDot:1
- +38 FOR %=$LENGTH(YLINE(X)):-1,10
- if $EXTRACT(YLINE(X),%)'=" "
- QUIT
- +39 SET YLINE(X)=$EXTRACT(YLINE(X),1,%)
- End DoDot:1
- +40 QUIT
- +41 ;
- +42 ;
- SETLINE(STEP) ; build line of display
- +1 ; step=incerment on y-axis
- +2 SET DATALINE=$EXTRACT(SPACE,1,69)
- +3 FOR %=5:5
- if '$DATA(COLUMN(%))
- QUIT
- SET VALUE=+COLUMN(%)
- SET CHAR=$PIECE(COLUMN(%),"*",2)
- IF VALUE'<(INCREMEN*STEP)
- Begin DoDot:1
- +4 ; set value on top of previous line
- +5 IF CHAR="^"
- SET X=$SELECT($GET(BARCHART):8,1:9)
- SET Y=X-1+%+$LENGTH(VALUE)
- SET YLINE(COUNT)=$EXTRACT(YLINE(COUNT),0,X+%-1)_VALUE_$EXTRACT(YLINE(COUNT),Y+1,200)
- +6 SET X=" "_CHAR
- IF $GET(BARCHART)
- IF CHAR="^"
- SET X="-----"
- +7 IF $GET(BARCHART)
- IF $EXTRACT(DATALINE,%-5)=" "
- SET DATALINE=$EXTRACT(DATALINE,0,%-6)_$SELECT(X["-":"-",1:"|")_$EXTRACT(DATALINE,%-4,200)
- +8 SET DATALINE=$EXTRACT(DATALINE,0,%-5)_X_$EXTRACT(DATALINE,%-3,200)
- SET $PIECE(COLUMN(%),"*",2)="|"
- End DoDot:1
- +9 IF AVERAGE'<(INCREMEN*STEP)
- IF '$GET(AVGFLAG)
- SET AVGFLAG=1
- SET AVGLINE=COUNT+1
- +10 QUIT