AQAOPC83 ; IHS/ORDC/LJF - PRINT PROVIDER PROFILE ;
;;1.01;QAI MANAGEMENT;;OCT 05, 1995
;
;This rtn prints the single provider profile giving totals for the
;findings, actions, performance levels on occurrences.
;
INIT ; >>> initialize variables
S (X,AQAOIOMX)=80 X:IOT'="HFS" ^%ZOSF("RM")
D INIT^AQAOUTIL S AQAOHCON="Patient"
S AQAOTY="OCCURRENCE PROVIDER PROFILE FOR"
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)
;
I '$D(^TMP("AQAOPC8",$J)) D G EXIT
.D HEADING^AQAOUTIL,HDG2
.W !,AQAOLINE,!!?30,">>> NO DATA FOUND <<<",!!
;
;
LOOP ; >>> loop thru med staff functions selected to check for data
S AQAOM=0
F S AQAOM=$O(AQAOMP(AQAOM)) Q:AQAOM="" Q:AQAOSTOP=U D
.I AQAOPAGE=0 D HEADING^AQAOUTIL,HDG2 I 1
.E D NEWPG^AQAOUTIL Q:AQAOSTOP=U D HDG2
.I '$D(^TMP("AQAOPC8",$J,AQAOM)) D Q
..W !!?AQAOIOMX-20/2,">>> NO DATA FOUND <<<"
.E D LIST
;
;
EXIT ; >>> eoj
I '$D(ZTQUEUED),IOST["C-" D PRTOPT^AQAOVAR
K ^TMP("AQAOPC8",$J) K ^TMP("AQAOPC8A",$J) K ^TMP("AQAOPC8B",$J)
D ^%ZISC D KILL^AQAOUTIL
Q
;
; >>> END OF MAIN RTN <<<
;
;
LIST ; >> SUBRTN to loop thru ^tmp and print cases
S AQAOIND=0
F S AQAOIND=$O(^TMP("AQAOPC8",$J,AQAOM,AQAOIND)) Q:AQAOIND="" Q:AQAOSTOP=U D
.W !!,"Indicator: ",$P(AQAOIND,U) ;print indicator #
.W ?24,$P(^AQAO(2,$P(AQAOIND,U,2),0),U,2),! ;print indicator name
.S AQAODT=0
.F S AQAODT=$O(^TMP("AQAOPC8",$J,AQAOM,AQAOIND,AQAODT)) Q:AQAODT="" Q:AQAOSTOP=U D
..S AQAOIFN=0
..F S AQAOIFN=$O(^TMP("AQAOPC8",$J,AQAOM,AQAOIND,AQAODT,AQAOIFN)) Q:AQAOIFN="" Q:AQAOSTOP=U D
...S AQAOS=^TMP("AQAOPC8",$J,AQAOM,AQAOIND,AQAODT,AQAOIFN)
...I $Y>(IOSL-4) D NEWPG^AQAOUTIL Q:AQAOSTOP=U D HDG2
...W !,$P(AQAOS,U) S Y=AQAODT X ^DD("DD") W ?10,Y ;case id&occ dat
...W ?24,$P($P(AQAOS,U,2),"//") ;find/act/type/attr
...W ?53,$P($P(AQAOS,U,2),"//",2) ;poten/out/ult
.D SUBTOTAL ;print subtotals at end of each ind
Q
;
;
;
SUBTOTAL ; >> SUBRTN to print subtotals for an indicator in 2 columns
S X="",$P(X,"_",50)="" W !,"Subtotals: ",?25,X
S (AQAOX,AQAOY,AQAOCNT)=0
F S:AQAOX]"" AQAOX=$O(^TMP("AQAOPC8A",$J,AQAOIND,AQAOX)) S:AQAOY]"" AQAOY=$O(^TMP("AQAOPC8B",$J,AQAOIND,AQAOY)) Q:(AQAOX=AQAOY) D
.I $Y>(IOSL-4) D NEWPG^AQAOUTIL Q:AQAOSTOP=U D HDG2
.W ! I AQAOX]"" S AQAOCNT=AQAOCNT+^TMP("AQAOPC8A",$J,AQAOIND,AQAOX)
.I AQAOX]"" W ?24,AQAOX,?45,$J(^TMP("AQAOPC8A",$J,AQAOIND,AQAOX),4)
.I AQAOY]"" W ?53,AQAOY,?70,$J(^TMP("AQAOPC8B",$J,AQAOIND,AQAOY),4)
W !?45,"----",?70,"----"
W !?45,$J(AQAOCNT,4),?70,$J(AQAOCNT,4)
Q
;
;
HDG2 ; >> SUBRTN to print second half of heading
W ?AQAOIOMX-$L(AQAOPRVN)/2,AQAOPRVN
W !?AQAOIOMX-$L(AQAORG)/2,AQAORG,!,AQAOLIN2
W !,"Case ID",?10,"Occ Date",?24,"Find/Actn/Type/Level"
W ?53,"Risk/Occ/Ultimate Outcomes",!,AQAOLINE
W:$D(AQAOM) !?AQAOIOMX-$L(AQAOMP(AQAOM))/2,AQAOMP(AQAOM)
Q
AQAOPC83 ; IHS/ORDC/LJF - PRINT PROVIDER PROFILE ;
+1 ;;1.01;QAI MANAGEMENT;;OCT 05, 1995
+2 ;
+3 ;This rtn prints the single provider profile giving totals for the
+4 ;findings, actions, performance levels on occurrences.
+5 ;
INIT ; >>> initialize variables
+1 SET (X,AQAOIOMX)=80
IF IOT'="HFS"
XECUTE ^%ZOSF("RM")
+2 DO INIT^AQAOUTIL
SET AQAOHCON="Patient"
+3 SET AQAOTY="OCCURRENCE PROVIDER PROFILE FOR"
+4 SET AQAORG=$EXTRACT(AQAOBD,4,5)_"/"_$EXTRACT(AQAOBD,6,7)_"/"_$EXTRACT(AQAOBD,2,3)_" to "
+5 SET AQAORG=AQAORG_$EXTRACT(AQAOED,4,5)_"/"_$EXTRACT(AQAOED,6,7)_"/"_$EXTRACT(AQAOED,2,3)
+6 ;
+7 IF '$DATA(^TMP("AQAOPC8",$JOB))
Begin DoDot:1
+8 DO HEADING^AQAOUTIL
DO HDG2
+9 WRITE !,AQAOLINE,!!?30,">>> NO DATA FOUND <<<",!!
End DoDot:1
GOTO EXIT
+10 ;
+11 ;
LOOP ; >>> loop thru med staff functions selected to check for data
+1 SET AQAOM=0
+2 FOR
SET AQAOM=$ORDER(AQAOMP(AQAOM))
IF AQAOM=""
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:1
+3 IF AQAOPAGE=0
DO HEADING^AQAOUTIL
DO HDG2
IF 1
+4 IF '$TEST
DO NEWPG^AQAOUTIL
IF AQAOSTOP=U
QUIT
DO HDG2
+5 IF '$DATA(^TMP("AQAOPC8",$JOB,AQAOM))
Begin DoDot:2
+6 WRITE !!?AQAOIOMX-20/2,">>> NO DATA FOUND <<<"
End DoDot:2
QUIT
+7 IF '$TEST
DO LIST
End DoDot:1
+8 ;
+9 ;
EXIT ; >>> eoj
+1 IF '$DATA(ZTQUEUED)
IF IOST["C-"
DO PRTOPT^AQAOVAR
+2 KILL ^TMP("AQAOPC8",$JOB)
KILL ^TMP("AQAOPC8A",$JOB)
KILL ^TMP("AQAOPC8B",$JOB)
+3 DO ^%ZISC
DO KILL^AQAOUTIL
+4 QUIT
+5 ;
+6 ; >>> END OF MAIN RTN <<<
+7 ;
+8 ;
LIST ; >> SUBRTN to loop thru ^tmp and print cases
+1 SET AQAOIND=0
+2 FOR
SET AQAOIND=$ORDER(^TMP("AQAOPC8",$JOB,AQAOM,AQAOIND))
IF AQAOIND=""
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:1
+3 ;print indicator #
WRITE !!,"Indicator: ",$PIECE(AQAOIND,U)
+4 ;print indicator name
WRITE ?24,$PIECE(^AQAO(2,$PIECE(AQAOIND,U,2),0),U,2),!
+5 SET AQAODT=0
+6 FOR
SET AQAODT=$ORDER(^TMP("AQAOPC8",$JOB,AQAOM,AQAOIND,AQAODT))
IF AQAODT=""
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:2
+7 SET AQAOIFN=0
+8 FOR
SET AQAOIFN=$ORDER(^TMP("AQAOPC8",$JOB,AQAOM,AQAOIND,AQAODT,AQAOIFN))
IF AQAOIFN=""
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:3
+9 SET AQAOS=^TMP("AQAOPC8",$JOB,AQAOM,AQAOIND,AQAODT,AQAOIFN)
+10 IF $Y>(IOSL-4)
DO NEWPG^AQAOUTIL
IF AQAOSTOP=U
QUIT
DO HDG2
+11 ;case id&occ dat
WRITE !,$PIECE(AQAOS,U)
SET Y=AQAODT
XECUTE ^DD("DD")
WRITE ?10,Y
+12 ;find/act/type/attr
WRITE ?24,$PIECE($PIECE(AQAOS,U,2),"//")
+13 ;poten/out/ult
WRITE ?53,$PIECE($PIECE(AQAOS,U,2),"//",2)
End DoDot:3
End DoDot:2
+14 ;print subtotals at end of each ind
DO SUBTOTAL
End DoDot:1
+15 QUIT
+16 ;
+17 ;
+18 ;
SUBTOTAL ; >> SUBRTN to print subtotals for an indicator in 2 columns
+1 SET X=""
SET $PIECE(X,"_",50)=""
WRITE !,"Subtotals: ",?25,X
+2 SET (AQAOX,AQAOY,AQAOCNT)=0
+3 FOR
IF AQAOX]""
SET AQAOX=$ORDER(^TMP("AQAOPC8A",$JOB,AQAOIND,AQAOX))
IF AQAOY]""
SET AQAOY=$ORDER(^TMP("AQAOPC8B",$JOB,AQAOIND,AQAOY))
IF (AQAOX=AQAOY)
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-4)
DO NEWPG^AQAOUTIL
IF AQAOSTOP=U
QUIT
DO HDG2
+5 WRITE !
IF AQAOX]""
SET AQAOCNT=AQAOCNT+^TMP("AQAOPC8A",$JOB,AQAOIND,AQAOX)
+6 IF AQAOX]""
WRITE ?24,AQAOX,?45,$JUSTIFY(^TMP("AQAOPC8A",$JOB,AQAOIND,AQAOX),4)
+7 IF AQAOY]""
WRITE ?53,AQAOY,?70,$JUSTIFY(^TMP("AQAOPC8B",$JOB,AQAOIND,AQAOY),4)
End DoDot:1
+8 WRITE !?45,"----",?70,"----"
+9 WRITE !?45,$JUSTIFY(AQAOCNT,4),?70,$JUSTIFY(AQAOCNT,4)
+10 QUIT
+11 ;
+12 ;
HDG2 ; >> SUBRTN to print second half of heading
+1 WRITE ?AQAOIOMX-$LENGTH(AQAOPRVN)/2,AQAOPRVN
+2 WRITE !?AQAOIOMX-$LENGTH(AQAORG)/2,AQAORG,!,AQAOLIN2
+3 WRITE !,"Case ID",?10,"Occ Date",?24,"Find/Actn/Type/Level"
+4 WRITE ?53,"Risk/Occ/Ultimate Outcomes",!,AQAOLINE
+5 IF $DATA(AQAOM)
WRITE !?AQAOIOMX-$LENGTH(AQAOMP(AQAOM))/2,AQAOMP(AQAOM)
+6 QUIT
