AQAOPC42 ; IHS/ORDC/LJF - OCC WITH FINDINGS/ACTIONS ;
;;1.01;QAI MANAGEMENT;;OCT 05, 1995
;
;This rtn prints the trending report for occurrences with finding and
;action data, subtotaling each.
;
INIT ; >>> initialize variables
D INIT^AQAOUTIL S AQAOHCON="Patient"
S AQAOTY="OCCURRENCES WITH FINDINGS & ACTIONS"
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)
K ^TMP("AQAO",$J)
;
MAIN ; >>> main calls
I '$D(^TMP("AQAOPC4",$J)) D HEADING^AQAOUTIL,HDG1 W !!,"NO DATA FOUND FOR DATE RANGE SPECIFIED",!! G END
D LISTING
I AQAOSTOP'=U D SUMMARY^AQAOPC43
;
END ; >>> eoj
I $D(AQAODLM) W !!,*7,"*** STOP CAPTURE NOW! ***",!
D ^%ZISC I '$D(ZTQUEUED) D PRTOPT^AQAOVAR
K ^TMP("AQAOPC4",$J),^TMP("AQAO",$J)
D KILL^AQAOUTIL Q
;
;
LISTING ; >> SUBRTN to print occurrence listing if selected
I $D(AQAODLM),AQAOTYPE="L" D DLMHDG I 1 ;print heading
E I AQAOTYPE="L" D HEADING^AQAOUTIL,HDG1
;
S AQAOSUB=0 I '$D(AQAOXSN) D LIST2 Q ;no spec sorts
F S AQAOSUB=$O(^TMP("AQAOPC4",$J,AQAOSUB)) Q:AQAOSUB="" Q:AQAOSTOP=U D LIST2 ;spec review sort
Q
;
;
LIST2 ; >> SUBRTN for each AQAOSUB list occ with find/actions
I AQAOSUB'=0 W:AQAOTYPE="L" !!?AQAOIOMX-$L(AQAOSUB)/2,AQAOSUB,!
S AQAODT=0
F S AQAODT=$O(^TMP("AQAOPC4",$J,AQAOSUB,AQAODT)) Q:AQAODT="" Q:AQAOSTOP=U D
.S AQAON=0
.F S AQAON=$O(^TMP("AQAOPC4",$J,AQAOSUB,AQAODT,AQAON)) Q:AQAON="" Q:AQAOSTOP=U D
..S AQAOSTR=$G(^AQAOC(AQAON,0)) ;basic occ data
..I AQAOTYPE="L" D
...I '$D(AQAODLM),($Y>(IOSL-2)) 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,AQAODLM ;case&date ASCII
...E W !,$P(AQAOSTR,U),?9,Y ;print case & date
...K ^UTILITY("DIQ1",$J) S DIC="^AQAOC(",DA=AQAON,DR=".025" D EN^DIQ1
...W:'$D(AQAODLM) ?22
...W ^UTILITY("DIQ1",$J,9002167,AQAON,.025) ;age at time of occ
...W:$D(AQAODLM) AQAODLM W:'$D(AQAODLM) ?30
...W $P(^DPT($P(^AQAOC(AQAON,0),U,2),0),U,2) ;patient's sex
...W:$D(AQAODLM) AQAODLM W:'$D(AQAODLM) ?35
...W $S(+^AQAOC(AQAON,1)=0:"OPEN",1:"CLOSED") ;case status
..;
..D FINDING
..;print last stage
..I AQAOTYPE="L" W:$D(AQAODLM) AQAODLM W:'$D(AQAODLM) ?45 W AQAOS
..;print last finding
..I AQAOTYPE="L" W:$D(AQAODLM) AQAODLM W:'$D(AQAODLM) ?55 W AQAOF
..;print last action
..I AQAOTYPE="L" W:$D(AQAODLM) AQAODLM W:'$D(AQAODLM) ?65 W AQAOG
Q
;
;
FINDING ; >> SUBRTN to find last finding to date for occ
S (AQAOF,AQAOS,AQAOG,X,Y,Z)="" ;init finding/stage/action to null
I $P(^AQAOC(AQAON,1),U)=1 D ;closed occurrences
.S X=$P($G(^AQAOC(AQAON,"FINAL")),U,4) S:X="" X="??" ;finding
.S Y=$P($G(^AQAOC(AQAON,"FINAL")),U,2) S:Y="" Y="??" ;stage
.S Z=$P($G(^AQAOC(AQAON,"FINAL")),U,6) S:Z="" Z="??" ;action
;
I X]"" G COUNT
S (X,AQAOY)=0 F S X=$O(^AQAOC(AQAON,"REV",X)) Q:X'=+X S AQAOY=X
I AQAOY>0 D ;else get finding for last review
.S X=$P(^AQAOC(AQAON,"REV",AQAOY,0),U,5)
.S Y=$P(^AQAOC(AQAON,"REV",AQAOY,0),U)
.S Z=$P(^AQAOC(AQAON,"REV",AQAOY,0),U,7)
G COUNT:X]""
;else get initial finding and action
S X=$P($G(^AQAOC(AQAON,1)),U,5)
S Y=$P($G(^AQAOC(AQAON,1)),U,3)
S Z=$P($G(^AQAOC(AQAON,1)),U,6)
;
COUNT ;increment counts
I X="??" D
.S AQAOF=X
.S ^TMP("AQAO",$J,"F",AQAOSUB,X)=$G(^TMP("AQAO",$J,"F",AQAOSUB,X))+1
E D
.S AQAOF=$P(^AQAO(8,X,0),U,2)
.S ^TMP("AQAO",$J,"F",AQAOSUB,$P(^AQAO(8,X,0),U))=$G(^TMP("AQAO",$J,"F",AQAOSUB,$P(^AQAO(8,X,0),U)))+1
S AQAOS=$S(Y="??":Y,1:$P(^AQAO(7,Y,0),U,2))
;
I Z="??" D
.S AQAOG=Z
.S ^TMP("AQAO",$J,"A",AQAOSUB,Z)=$G(^TMP("AQAO",$J,"A",AQAOSUB,Z))+1
E D
.S AQAOG=$P(^AQAO(6,Z,0),U,2)
.S ^TMP("AQAO",$J,"A",AQAOSUB,$P(^AQAO(6,Z,0),U))=$G(^TMP("AQAO",$J,"A",AQAOSUB,$P(^AQAO(6,Z,0),U)))+1
Q
;
;
HDG1 ; >> SUBRTN for second half of heading
W ?30,"(OCCURRENCE LISTINGS)",!?30,AQAORG,!,AQAOLINE
W !,"Case #",?9,"Occ Date",?23,"Age",?29,"Sex",?35,"Status",?45,"Stage"
W ?55,"Findings",?65,"Actions"
W !,AQAOLINE
S X="** "_$P(^AQAO(2,AQAOIND,0),U)_" "_$P(^(0),U,2)_" **"
W !!?AQAOIOMX-$L(X)/2,X,! ;indicator # and name
Q
;
;
HDG2 ; >> SUBRTN for second half of heading2
W ?33,"(SUMMARY PAGE)",!?30,AQAORG,!,AQAOLINE,!
Q
;
;
DLMHDG ; >> SUBRTN for ASCII heading for listing portion
W !!!!,"***OCCURRENCE LISTINGS WITH FINDINGS & ACTIONS***",!,AQAORG,!
W !,"Printed by ",AQAODUZ," Printed on " S %H=$H D YX^%DTC W Y
F I="Case #","Occ Date","Age","Sex","Status","Stage","Finding","Action" W I,AQAODLM
Q
AQAOPC42 ; IHS/ORDC/LJF - OCC WITH FINDINGS/ACTIONS ;
+1 ;;1.01;QAI MANAGEMENT;;OCT 05, 1995
+2 ;
+3 ;This rtn prints the trending report for occurrences with finding and
+4 ;action data, subtotaling each.
+5 ;
INIT ; >>> initialize variables
+1 DO INIT^AQAOUTIL
SET AQAOHCON="Patient"
+2 SET AQAOTY="OCCURRENCES WITH FINDINGS & ACTIONS"
+3 SET AQAORG=$EXTRACT(AQAOBD,4,5)_"/"_$EXTRACT(AQAOBD,6,7)_"/"_$EXTRACT(AQAOBD,2,3)_" to "
+4 SET AQAORG=AQAORG_$EXTRACT(AQAOED,4,5)_"/"_$EXTRACT(AQAOED,6,7)_"/"_$EXTRACT(AQAOED,2,3)
+5 KILL ^TMP("AQAO",$JOB)
+6 ;
MAIN ; >>> main calls
+1 IF '$DATA(^TMP("AQAOPC4",$JOB))
DO HEADING^AQAOUTIL
DO HDG1
WRITE !!,"NO DATA FOUND FOR DATE RANGE SPECIFIED",!!
GOTO END
+2 DO LISTING
+3 IF AQAOSTOP'=U
DO SUMMARY^AQAOPC43
+4 ;
END ; >>> eoj
+1 IF $DATA(AQAODLM)
WRITE !!,*7,"*** STOP CAPTURE NOW! ***",!
+2 DO ^%ZISC
IF '$DATA(ZTQUEUED)
DO PRTOPT^AQAOVAR
+3 KILL ^TMP("AQAOPC4",$JOB),^TMP("AQAO",$JOB)
+4 DO KILL^AQAOUTIL
QUIT
+5 ;
+6 ;
LISTING ; >> SUBRTN to print occurrence listing if selected
+1 ;print heading
IF $DATA(AQAODLM)
IF AQAOTYPE="L"
DO DLMHDG
IF 1
+2 IF '$TEST
IF AQAOTYPE="L"
DO HEADING^AQAOUTIL
DO HDG1
+3 ;
+4 ;no spec sorts
SET AQAOSUB=0
IF '$DATA(AQAOXSN)
DO LIST2
QUIT
+5 ;spec review sort
FOR
SET AQAOSUB=$ORDER(^TMP("AQAOPC4",$JOB,AQAOSUB))
IF AQAOSUB=""
QUIT
IF AQAOSTOP=U
QUIT
DO LIST2
+6 QUIT
+7 ;
+8 ;
LIST2 ; >> SUBRTN for each AQAOSUB list occ with find/actions
+1 IF AQAOSUB'=0
IF AQAOTYPE="L"
WRITE !!?AQAOIOMX-$LENGTH(AQAOSUB)/2,AQAOSUB,!
+2 SET AQAODT=0
+3 FOR
SET AQAODT=$ORDER(^TMP("AQAOPC4",$JOB,AQAOSUB,AQAODT))
IF AQAODT=""
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:1
+4 SET AQAON=0
+5 FOR
SET AQAON=$ORDER(^TMP("AQAOPC4",$JOB,AQAOSUB,AQAODT,AQAON))
IF AQAON=""
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:2
+6 ;basic occ data
SET AQAOSTR=$GET(^AQAOC(AQAON,0))
+7 IF AQAOTYPE="L"
Begin DoDot:3
+8 IF '$DATA(AQAODLM)
IF ($Y>(IOSL-2))
DO NEWPG^AQAOUTIL
IF AQAOSTOP=U
QUIT
DO HDG1
+9 SET Y=AQAODT
XECUTE ^DD("DD")
IF $DATA(AQAODLM)
SET Y=$PIECE(Y,",")_" "_$PIECE(Y,",",2)
+10 ;case&date ASCII
IF $DATA(AQAODLM)
WRITE !,$PIECE(AQAOSTR,U),AQAODLM,Y,AQAODLM
+11 ;print case & date
IF '$TEST
WRITE !,$PIECE(AQAOSTR,U),?9,Y
+12 KILL ^UTILITY("DIQ1",$JOB)
SET DIC="^AQAOC("
SET DA=AQAON
SET DR=".025"
DO EN^DIQ1
+13 IF '$DATA(AQAODLM)
WRITE ?22
+14 ;age at time of occ
WRITE ^UTILITY("DIQ1",$JOB,9002167,AQAON,.025)
+15 IF $DATA(AQAODLM)
WRITE AQAODLM
IF '$DATA(AQAODLM)
WRITE ?30
+16 ;patient's sex
WRITE $PIECE(^DPT($PIECE(^AQAOC(AQAON,0),U,2),0),U,2)
+17 IF $DATA(AQAODLM)
WRITE AQAODLM
IF '$DATA(AQAODLM)
WRITE ?35
+18 ;case status
WRITE $SELECT(+^AQAOC(AQAON,1)=0:"OPEN",1:"CLOSED")
End DoDot:3
+19 ;
+20 DO FINDING
+21 ;print last stage
+22 IF AQAOTYPE="L"
IF $DATA(AQAODLM)
WRITE AQAODLM
IF '$DATA(AQAODLM)
WRITE ?45
WRITE AQAOS
+23 ;print last finding
+24 IF AQAOTYPE="L"
IF $DATA(AQAODLM)
WRITE AQAODLM
IF '$DATA(AQAODLM)
WRITE ?55
WRITE AQAOF
+25 ;print last action
+26 IF AQAOTYPE="L"
IF $DATA(AQAODLM)
WRITE AQAODLM
IF '$DATA(AQAODLM)
WRITE ?65
WRITE AQAOG
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;
+29 ;
FINDING ; >> SUBRTN to find last finding to date for occ
+1 ;init finding/stage/action to null
SET (AQAOF,AQAOS,AQAOG,X,Y,Z)=""
+2 ;closed occurrences
IF $PIECE(^AQAOC(AQAON,1),U)=1
Begin DoDot:1
+3 ;finding
SET X=$PIECE($GET(^AQAOC(AQAON,"FINAL")),U,4)
IF X=""
SET X="??"
+4 ;stage
SET Y=$PIECE($GET(^AQAOC(AQAON,"FINAL")),U,2)
IF Y=""
SET Y="??"
+5 ;action
SET Z=$PIECE($GET(^AQAOC(AQAON,"FINAL")),U,6)
IF Z=""
SET Z="??"
End DoDot:1
+6 ;
+7 IF X]""
GOTO COUNT
+8 SET (X,AQAOY)=0
FOR
SET X=$ORDER(^AQAOC(AQAON,"REV",X))
IF X'=+X
QUIT
SET AQAOY=X
+9 ;else get finding for last review
IF AQAOY>0
Begin DoDot:1
+10 SET X=$PIECE(^AQAOC(AQAON,"REV",AQAOY,0),U,5)
+11 SET Y=$PIECE(^AQAOC(AQAON,"REV",AQAOY,0),U)
+12 SET Z=$PIECE(^AQAOC(AQAON,"REV",AQAOY,0),U,7)
End DoDot:1
+13 IF X]""
GOTO COUNT
+14 ;else get initial finding and action
+15 SET X=$PIECE($GET(^AQAOC(AQAON,1)),U,5)
+16 SET Y=$PIECE($GET(^AQAOC(AQAON,1)),U,3)
+17 SET Z=$PIECE($GET(^AQAOC(AQAON,1)),U,6)
+18 ;
COUNT ;increment counts
+1 IF X="??"
Begin DoDot:1
+2 SET AQAOF=X
+3 SET ^TMP("AQAO",$JOB,"F",AQAOSUB,X)=$GET(^TMP("AQAO",$JOB,"F",AQAOSUB,X))+1
End DoDot:1
+4 IF '$TEST
Begin DoDot:1
+5 SET AQAOF=$PIECE(^AQAO(8,X,0),U,2)
+6 SET ^TMP("AQAO",$JOB,"F",AQAOSUB,$PIECE(^AQAO(8,X,0),U))=$GET(^TMP("AQAO",$JOB,"F",AQAOSUB,$PIECE(^AQAO(8,X,0),U)))+1
End DoDot:1
+7 SET AQAOS=$SELECT(Y="??":Y,1:$PIECE(^AQAO(7,Y,0),U,2))
+8 ;
+9 IF Z="??"
Begin DoDot:1
+10 SET AQAOG=Z
+11 SET ^TMP("AQAO",$JOB,"A",AQAOSUB,Z)=$GET(^TMP("AQAO",$JOB,"A",AQAOSUB,Z))+1
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 SET AQAOG=$PIECE(^AQAO(6,Z,0),U,2)
+14 SET ^TMP("AQAO",$JOB,"A",AQAOSUB,$PIECE(^AQAO(6,Z,0),U))=$GET(^TMP("AQAO",$JOB,"A",AQAOSUB,$PIECE(^AQAO(6,Z,0),U)))+1
End DoDot:1
+15 QUIT
+16 ;
+17 ;
HDG1 ; >> SUBRTN for second half of heading
+1 WRITE ?30,"(OCCURRENCE LISTINGS)",!?30,AQAORG,!,AQAOLINE
+2 WRITE !,"Case #",?9,"Occ Date",?23,"Age",?29,"Sex",?35,"Status",?45,"Stage"
+3 WRITE ?55,"Findings",?65,"Actions"
+4 WRITE !,AQAOLINE
+5 SET X="** "_$PIECE(^AQAO(2,AQAOIND,0),U)_" "_$PIECE(^(0),U,2)_" **"
+6 ;indicator # and name
WRITE !!?AQAOIOMX-$LENGTH(X)/2,X,!
+7 QUIT
+8 ;
+9 ;
HDG2 ; >> SUBRTN for second half of heading2
+1 WRITE ?33,"(SUMMARY PAGE)",!?30,AQAORG,!,AQAOLINE,!
+2 QUIT
+3 ;
+4 ;
DLMHDG ; >> SUBRTN for ASCII heading for listing portion
+1 WRITE !!!!,"***OCCURRENCE LISTINGS WITH FINDINGS & ACTIONS***",!,AQAORG,!
+2 WRITE !,"Printed by ",AQAODUZ," Printed on "
SET %H=$HOROLOG
DO YX^%DTC
WRITE Y
+3 FOR I="Case #","Occ Date","Age","Sex","Status","Stage","Finding","Action"
WRITE I,AQAODLM
+4 QUIT
