- 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
