AQAOPC12 ; IHS/ORDC/LJF - PRINT OCC BY INDICATOR W/ CRIT ;
;;1.01;QAI MANAGEMENT;;OCT 05, 1995
;
;This rtn contains the code to print the trending report by review
;criteria based on the selected indicator and date range.
;
INIT ; >>> initialize variables
I $D(AQAOIOMX),IOT'="HFS" D
.S X=AQAOIOMX X ^%ZOSF("RM")
.S X="IOPTCH16" D ENDR^%ZISS W IOPTCH16
D INIT^AQAOUTIL S AQAOHCON="Patient"
S AQAOTY="OCCURRENCES BY INDICATOR WITH CRITERIA VALUES"
S AQAORG=$E(AQAOBD,4,5)_"/"_$E(AQAOBD,6,7)_"/"_$E(AQAOBD,2,3)_" to "
S AQAORG=AQAORG_$E(AQAOED,4,5)_"/"_$E(AQAOED,6,7)_"/"_$E(AQAOED,2,3)
;
; >>> print report
I AQAOTYP="L" D LISTING
I AQAOSTOP'=U D SUMMARY^AQAOPC13
;
END ; >>> eoj
I $D(AQAODLM) W !!,*7,"*** STOP CAPTURE NOW ***",!
I $D(AQAOIOMX),IOT'="HFS" S X=IOM X ^%ZOSF("RM")
I $D(IOPTCH16),IOT'="HFS" S X="IOPTCH10" D ENDR^%ZISS W IOPTCH10
D ^%ZISC I AQAOSTOP=U W @IOF
I '$D(ZTQUEUED),AQAOSTOP="" D PRTOPT^AQAOVAR
K ^TMP("AQAOPC1",$J) K ^TMP("AQAOPC11",$J)
K IOPTCH10,IOPTCH16 D KILL^AQAOUTIL Q
;
;
LISTING ; >>> SUBRTN to print occurrence listing if selected
Q:'$D(^TMP("AQAOPC1",$J)) ;no entries
I $D(AQAODLM) D DLMHDG I 1 ;ascii file heading
E D HEADING^AQAOUTIL,HDG1 ;printed heading
S AQAOSUB=0 I '$D(AQAOXSN) D LIST2 Q ;straight listing
; ;extra sort listing
F S AQAOSUB=$O(^TMP("AQAOPC1",$J,AQAOSUB)) Q:AQAOSUB="" Q:AQAOSTOP=U D LIST2
Q
;
;
LIST2 ; >> SUBRTN for each AQAOSUB list occ and criteria
I AQAOSUB'=0 W !!?AQAOIOMX-$L(AQAOSUB)/2,AQAOSUB,! ;extra sort headng
S AQAODT=0
F S AQAODT=$O(^TMP("AQAOPC1",$J,AQAOSUB,AQAODT)) Q:AQAODT="" Q:AQAOSTOP=U D
.S AQAON=0
.F S AQAON=$O(^TMP("AQAOPC1",$J,AQAOSUB,AQAODT,AQAON)) Q:AQAON="" Q:AQAOSTOP=U D
..S AQAOSTR=^TMP("AQAOPC1",$J,AQAOSUB,AQAODT,AQAON)
..I '$D(AQAODLM),($Y>(IOSL-4)) D NEWPG^AQAOUTIL Q:AQAOSTOP=U D HDG1
..S Y=AQAODT X ^DD("DD") I $D(AQAODLM) S Y=$P(Y,",")_" "_$P(Y,",",2)
..I $D(AQAODLM) W !,$P(AQAOSTR,U),AQAODLM,Y ;case & date ASCII format
..E W !,$P(AQAOSTR,U),?10,$E(Y_" ",1,11) ;print case & date
..D CRITLOOP ;loop thru criteria and print values
Q
;
;
CRITLOOP ; >> SUBRTN to loop thru crit values for occurrence and print
K AQAOCX S (Z,AQAOSV)=1
;put criteria into print order, then print them
F I=2:2 S X=$P(AQAOSTR,U,I),Y=$P(AQAOSTR,U,I+1) Q:X="" D
.S Y=Y_" ",Y=$E(Y,1,6) ;make sure 6 characters long
LOOPBACK .I $D(AQAOCX(Z,X)) S Z=Z+1 G LOOPBACK ;some may have more than one
.S AQAOCX(Z,X)=Y ;set array=line# (Z) & value (Y)
.S:(Z>AQAOSV) AQAOSV=Z S Z=1 ;update highest line #, reset Z
;
G CRITPRT:AQAOSV=1 ;one line of data only
S X=0 F S X=$O(AQAOCR(X)) Q:X="" D ;fill in lines #2 and above
.F Z=2:1:AQAOSV I '$D(AQAOCX(Z,X)) S AQAOCX(Z,X)=" "
;
CRITPRT S Z=0 F S Z=$O(AQAOCX(Z)) Q:Z="" W:Z>1 !?21 D ;print each line
.S X=0 ;print each criterion value
.F S X=$O(AQAOCX(Z,X)) Q:X="" D
..W $S($D(AQAODLM):AQAODLM,1:" "),AQAOCX(Z,X)
Q
;
;
HDG1 ; >> SUBRTN to print second half of heading
S X=$P(^AQAO(2,AQAOIND,0),U)_": "_$P(^(0),U,2) ;indicatr
W ?AQAOIOMX-$L(X)/2,X,!?AQAOIOMX-$L(AQAORG)/2,AQAORG
W !,AQAOLINE,!,"Case #",?11,"Occ Date "
S X=0 F S X=$O(AQAOCR(X)) Q:X="" S Y=" CR"_X_" ",Y=$E(Y,1,8) W Y
Q
;
;
DLMHDG ; >> SUBRTN to print second half of heading for ASCII format
W !!!!,"***OCCURRENCE LISTINGS***",!,AQAORG,!
W !,"Printed by ",AQAODUZ," Printed on " S %H=$H D YX^%DTC W Y
W !,"Case #",AQAODLM,"Occ Date "
S X=0 F S X=$O(AQAOCR(X)) Q:X="" W AQAODLM,"CR",X
Q
AQAOPC12 ; IHS/ORDC/LJF - PRINT OCC BY INDICATOR W/ CRIT ;
+1 ;;1.01;QAI MANAGEMENT;;OCT 05, 1995
+2 ;
+3 ;This rtn contains the code to print the trending report by review
+4 ;criteria based on the selected indicator and date range.
+5 ;
INIT ; >>> initialize variables
+1 IF $DATA(AQAOIOMX)
IF IOT'="HFS"
Begin DoDot:1
+2 SET X=AQAOIOMX
XECUTE ^%ZOSF("RM")
+3 SET X="IOPTCH16"
DO ENDR^%ZISS
WRITE IOPTCH16
End DoDot:1
+4 DO INIT^AQAOUTIL
SET AQAOHCON="Patient"
+5 SET AQAOTY="OCCURRENCES BY INDICATOR WITH CRITERIA VALUES"
+6 SET AQAORG=$EXTRACT(AQAOBD,4,5)_"/"_$EXTRACT(AQAOBD,6,7)_"/"_$EXTRACT(AQAOBD,2,3)_" to "
+7 SET AQAORG=AQAORG_$EXTRACT(AQAOED,4,5)_"/"_$EXTRACT(AQAOED,6,7)_"/"_$EXTRACT(AQAOED,2,3)
+8 ;
+9 ; >>> print report
+10 IF AQAOTYP="L"
DO LISTING
+11 IF AQAOSTOP'=U
DO SUMMARY^AQAOPC13
+12 ;
END ; >>> eoj
+1 IF $DATA(AQAODLM)
WRITE !!,*7,"*** STOP CAPTURE NOW ***",!
+2 IF $DATA(AQAOIOMX)
IF IOT'="HFS"
SET X=IOM
XECUTE ^%ZOSF("RM")
+3 IF $DATA(IOPTCH16)
IF IOT'="HFS"
SET X="IOPTCH10"
DO ENDR^%ZISS
WRITE IOPTCH10
+4 DO ^%ZISC
IF AQAOSTOP=U
WRITE @IOF
+5 IF '$DATA(ZTQUEUED)
IF AQAOSTOP=""
DO PRTOPT^AQAOVAR
+6 KILL ^TMP("AQAOPC1",$JOB)
KILL ^TMP("AQAOPC11",$JOB)
+7 KILL IOPTCH10,IOPTCH16
DO KILL^AQAOUTIL
QUIT
+8 ;
+9 ;
LISTING ; >>> SUBRTN to print occurrence listing if selected
+1 ;no entries
IF '$DATA(^TMP("AQAOPC1",$JOB))
QUIT
+2 ;ascii file heading
IF $DATA(AQAODLM)
DO DLMHDG
IF 1
+3 ;printed heading
IF '$TEST
DO HEADING^AQAOUTIL
DO HDG1
+4 ;straight listing
SET AQAOSUB=0
IF '$DATA(AQAOXSN)
DO LIST2
QUIT
+5 ; ;extra sort listing
+6 FOR
SET AQAOSUB=$ORDER(^TMP("AQAOPC1",$JOB,AQAOSUB))
IF AQAOSUB=""
QUIT
IF AQAOSTOP=U
QUIT
DO LIST2
+7 QUIT
+8 ;
+9 ;
LIST2 ; >> SUBRTN for each AQAOSUB list occ and criteria
+1 ;extra sort headng
IF AQAOSUB'=0
WRITE !!?AQAOIOMX-$LENGTH(AQAOSUB)/2,AQAOSUB,!
+2 SET AQAODT=0
+3 FOR
SET AQAODT=$ORDER(^TMP("AQAOPC1",$JOB,AQAOSUB,AQAODT))
IF AQAODT=""
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:1
+4 SET AQAON=0
+5 FOR
SET AQAON=$ORDER(^TMP("AQAOPC1",$JOB,AQAOSUB,AQAODT,AQAON))
IF AQAON=""
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:2
+6 SET AQAOSTR=^TMP("AQAOPC1",$JOB,AQAOSUB,AQAODT,AQAON)
+7 IF '$DATA(AQAODLM)
IF ($Y>(IOSL-4))
DO NEWPG^AQAOUTIL
IF AQAOSTOP=U
QUIT
DO HDG1
+8 SET Y=AQAODT
XECUTE ^DD("DD")
IF $DATA(AQAODLM)
SET Y=$PIECE(Y,",")_" "_$PIECE(Y,",",2)
+9 ;case & date ASCII format
IF $DATA(AQAODLM)
WRITE !,$PIECE(AQAOSTR,U),AQAODLM,Y
+10 ;print case & date
IF '$TEST
WRITE !,$PIECE(AQAOSTR,U),?10,$EXTRACT(Y_" ",1,11)
+11 ;loop thru criteria and print values
DO CRITLOOP
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
+14 ;
CRITLOOP ; >> SUBRTN to loop thru crit values for occurrence and print
+1 KILL AQAOCX
SET (Z,AQAOSV)=1
+2 ;put criteria into print order, then print them
+3 FOR I=2:2
SET X=$PIECE(AQAOSTR,U,I)
SET Y=$PIECE(AQAOSTR,U,I+1)
IF X=""
QUIT
Begin DoDot:1
+4 ;make sure 6 characters long
SET Y=Y_" "
SET Y=$EXTRACT(Y,1,6)
LOOPBACK ;some may have more than one
IF $DATA(AQAOCX(Z,X))
SET Z=Z+1
GOTO LOOPBACK
+1 ;set array=line# (Z) & value (Y)
SET AQAOCX(Z,X)=Y
+2 ;update highest line #, reset Z
IF (Z>AQAOSV)
SET AQAOSV=Z
SET Z=1
End DoDot:1
+3 ;
+4 ;one line of data only
IF AQAOSV=1
GOTO CRITPRT
+5 ;fill in lines #2 and above
SET X=0
FOR
SET X=$ORDER(AQAOCR(X))
IF X=""
QUIT
Begin DoDot:1
+6 FOR Z=2:1:AQAOSV
IF '$DATA(AQAOCX(Z,X))
SET AQAOCX(Z,X)=" "
End DoDot:1
+7 ;
CRITPRT ;print each line
SET Z=0
FOR
SET Z=$ORDER(AQAOCX(Z))
IF Z=""
QUIT
IF Z>1
WRITE !?21
Begin DoDot:1
+1 ;print each criterion value
SET X=0
+2 FOR
SET X=$ORDER(AQAOCX(Z,X))
IF X=""
QUIT
Begin DoDot:2
+3 WRITE $SELECT($DATA(AQAODLM):AQAODLM,1:" "),AQAOCX(Z,X)
End DoDot:2
End DoDot:1
+4 QUIT
+5 ;
+6 ;
HDG1 ; >> SUBRTN to print second half of heading
+1 ;indicatr
SET X=$PIECE(^AQAO(2,AQAOIND,0),U)_": "_$PIECE(^(0),U,2)
+2 WRITE ?AQAOIOMX-$LENGTH(X)/2,X,!?AQAOIOMX-$LENGTH(AQAORG)/2,AQAORG
+3 WRITE !,AQAOLINE,!,"Case #",?11,"Occ Date "
+4 SET X=0
FOR
SET X=$ORDER(AQAOCR(X))
IF X=""
QUIT
SET Y=" CR"_X_" "
SET Y=$EXTRACT(Y,1,8)
WRITE Y
+5 QUIT
+6 ;
+7 ;
DLMHDG ; >> SUBRTN to print second half of heading for ASCII format
+1 WRITE !!!!,"***OCCURRENCE LISTINGS***",!,AQAORG,!
+2 WRITE !,"Printed by ",AQAODUZ," Printed on "
SET %H=$HOROLOG
DO YX^%DTC
WRITE Y
+3 WRITE !,"Case #",AQAODLM,"Occ Date "
+4 SET X=0
FOR
SET X=$ORDER(AQAOCR(X))
IF X=""
QUIT
WRITE AQAODLM,"CR",X
+5 QUIT
