- 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