AQAOPC22 ; IHS/ORDC/LJF - PRINT OCC BY INDICATOR W/ ICD ;
;;1.01;QAI MANAGEMENT;;OCT 05, 1995
;
;This rtn is the main driver to print the trending report by diagnosis
;and procedure.
;
INIT ; >>> initialize variables
I AQAOTYPE="L",IOT'="HFS" D
.S (AQAOIOMX,X)=132 X ^%ZOSF("RM") ;lstng needs 132col
D INIT^AQAOUTIL S AQAOHCON="Patient"
S AQAOTY="OCCURRENCES BY INDICATOR WITH DX/PROCEDURES"
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("AQAOPC2",$J)) D HEADING^AQAOUTIL,HDG1 W !!,"NO DATA FOR DATE RANGE SPECIFIED",!! G END ;no entries
D LISTING
I AQAOSTOP'=U D SUMMARY^AQAOPC24
;
;
END ; >>> eoj
I $D(AQAODLM) W !!,*7,"*** STOP CAPTURE NOW! ***",!
I AQAOTYPE="L",IOT'="HFS" S X=IOM X ^%ZOSF("RM") ;reset right margin
D ^%ZISC I '$D(ZTQUEUED) D PRTOPT^AQAOVAR
K ^TMP("AQAOPC2",$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("AQAOPC2",$J,AQAOSUB)) Q:AQAOSUB="" Q:AQAOSTOP=U D LIST2 ;spec review sort
Q
;
;
LIST2 ; >> SUBRTN to print occ for each AQAOSUB
I AQAOSUB'=0 W:AQAOTYPE="L" !!?AQAOIOMX-$L(AQAOSUB)/2,AQAOSUB,!
S AQAODT=0
F S AQAODT=$O(^TMP("AQAOPC2",$J,AQAOSUB,AQAODT)) Q:AQAODT="" Q:AQAOSTOP=U D
.S AQAON=0
.F S AQAON=$O(^TMP("AQAOPC2",$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
..;
..D FINDING
..;print last finding
..I AQAOTYPE="L" W:$D(AQAODLM) "," W:'$D(AQAODLM) ?35
..I AQAOTYPE="L" W AQAOF,$S($D(AQAODLM):AQAODLM,AQAOS="":"",1:" / "),AQAOS
..;increment count for this finding
..I AQAOF]"" S ^TMP("AQAO",$J,"F",AQAOSUB,AQAOF)=$G(^TMP("AQAO",$J,"F",AQAOSUB,AQAOF))+1
..;
..D ICDPRINT^AQAOPC23 ;print all icd codes defined for occ
Q
;
;
FINDING ; >> SUBRTN to find last finding to date for occ
S (AQAOF,AQAOS)="" ;initialize finding & stage to null
S X=$P($G(^AQAOC(AQAON,"FINAL")),U,4) ;if final finding at closure
S Y=$P($G(^AQAOC(AQAON,"FINAL")),U,2) ;final review stage
I X]"" S AQAOF=$P(^AQAO(8,X,0),U,2) S:Y]"" AQAOS=$P(^AQAO(7,Y,0),U,2) Q
S (X,Y)=0 F S X=$O(^AQAOC(AQAON,"REV",X)) Q:X'=+X S Y=X
I Y>0 D Q ;else get finding for last review
.S X=$P(^AQAOC(AQAON,"REV",Y,0),U,5) S:X]"" AQAOF=$P(^AQAO(8,X,0),U,2)
.S X=$P(^AQAOC(AQAON,"REV",Y,0),U) S:X]"" AQAOS=$P(^AQAO(7,X,0),U,2)
; ;else get initial finding
S X=$P($G(^AQAOC(AQAON,1)),U,5) S:X]"" AQAOF=$P(^AQAO(8,X,0),U,2)
S X=$P($G(^AQAOC(AQAON,1)),U,3) S:X]"" AQAOS=$P(^AQAO(7,X,0),U,2)
Q
;
;
HDG1 ; >> SUBRTN for second half of heading
S X="(OCCURRENCE LISTINGS)" W ?AQAOIOMX-$L(X)/2,X
W !?AQAOIOMX-$L(AQAORG)/2,AQAORG,!,AQAOLINE
W !,"Case #",?9,"Occ Date",?23,"Age",?29,"Sex",?34,"Fndg/Stg"
W ?45,"Prov",?53,"Diagnoses",?92,"Procedures"
W !,AQAOLINE,!
I AQAODESC]"" W !?AQAOIOMX-$L(AQAODESC)/2,AQAODESC,!
Q
;
;
DLMHDG ; >> SUBRTN for ASCII heading for listing portion
W !!!!,"***OCCURRENCE LISTINGS WITH ICD CODES***",!,AQAORG,!
W !,"Printed by ",AQAODUZ," Printed on " S %H=$H D YX^%DTC W Y
I AQAODESC]"" W !,AQAODESC,!
F I="Case #","Occ Date","Age","Sex","Finding","Stage" W I,AQAODLM
F I="Provider","DX code","DX narrative","Procedure code","Procedure narrative" W I,AQAODLM
Q
AQAOPC22 ; IHS/ORDC/LJF - PRINT OCC BY INDICATOR W/ ICD ;
+1 ;;1.01;QAI MANAGEMENT;;OCT 05, 1995
+2 ;
+3 ;This rtn is the main driver to print the trending report by diagnosis
+4 ;and procedure.
+5 ;
INIT ; >>> initialize variables
+1 IF AQAOTYPE="L"
IF IOT'="HFS"
Begin DoDot:1
+2 ;lstng needs 132col
SET (AQAOIOMX,X)=132
XECUTE ^%ZOSF("RM")
End DoDot:1
+3 DO INIT^AQAOUTIL
SET AQAOHCON="Patient"
+4 SET AQAOTY="OCCURRENCES BY INDICATOR WITH DX/PROCEDURES"
+5 SET AQAORG=$EXTRACT(AQAOBD,4,5)_"/"_$EXTRACT(AQAOBD,6,7)_"/"_$EXTRACT(AQAOBD,2,3)_" to "
+6 SET AQAORG=AQAORG_$EXTRACT(AQAOED,4,5)_"/"_$EXTRACT(AQAOED,6,7)_"/"_$EXTRACT(AQAOED,2,3)
+7 KILL ^TMP("AQAO",$JOB)
+8 ;
MAIN ; >>> main calls
+1 ;no entries
IF '$DATA(^TMP("AQAOPC2",$JOB))
DO HEADING^AQAOUTIL
DO HDG1
WRITE !!,"NO DATA FOR DATE RANGE SPECIFIED",!!
GOTO END
+2 DO LISTING
+3 IF AQAOSTOP'=U
DO SUMMARY^AQAOPC24
+4 ;
+5 ;
END ; >>> eoj
+1 IF $DATA(AQAODLM)
WRITE !!,*7,"*** STOP CAPTURE NOW! ***",!
+2 ;reset right margin
IF AQAOTYPE="L"
IF IOT'="HFS"
SET X=IOM
XECUTE ^%ZOSF("RM")
+3 DO ^%ZISC
IF '$DATA(ZTQUEUED)
DO PRTOPT^AQAOVAR
+4 KILL ^TMP("AQAOPC2",$JOB),^TMP("AQAO",$JOB)
DO KILL^AQAOUTIL
+5 QUIT
+6 ;
+7 ;
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("AQAOPC2",$JOB,AQAOSUB))
IF AQAOSUB=""
QUIT
IF AQAOSTOP=U
QUIT
DO LIST2
+6 QUIT
+7 ;
+8 ;
LIST2 ; >> SUBRTN to print occ for each AQAOSUB
+1 IF AQAOSUB'=0
IF AQAOTYPE="L"
WRITE !!?AQAOIOMX-$LENGTH(AQAOSUB)/2,AQAOSUB,!
+2 SET AQAODT=0
+3 FOR
SET AQAODT=$ORDER(^TMP("AQAOPC2",$JOB,AQAOSUB,AQAODT))
IF AQAODT=""
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:1
+4 SET AQAON=0
+5 FOR
SET AQAON=$ORDER(^TMP("AQAOPC2",$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)
End DoDot:3
+17 ;
+18 DO FINDING
+19 ;print last finding
+20 IF AQAOTYPE="L"
IF $DATA(AQAODLM)
WRITE ","
IF '$DATA(AQAODLM)
WRITE ?35
+21 IF AQAOTYPE="L"
WRITE AQAOF,$SELECT($DATA(AQAODLM):AQAODLM,AQAOS="":"",1:" / "),AQAOS
+22 ;increment count for this finding
+23 IF AQAOF]""
SET ^TMP("AQAO",$JOB,"F",AQAOSUB,AQAOF)=$GET(^TMP("AQAO",$JOB,"F",AQAOSUB,AQAOF))+1
+24 ;
+25 ;print all icd codes defined for occ
DO ICDPRINT^AQAOPC23
End DoDot:2
End DoDot:1
+26 QUIT
+27 ;
+28 ;
FINDING ; >> SUBRTN to find last finding to date for occ
+1 ;initialize finding & stage to null
SET (AQAOF,AQAOS)=""
+2 ;if final finding at closure
SET X=$PIECE($GET(^AQAOC(AQAON,"FINAL")),U,4)
+3 ;final review stage
SET Y=$PIECE($GET(^AQAOC(AQAON,"FINAL")),U,2)
+4 IF X]""
SET AQAOF=$PIECE(^AQAO(8,X,0),U,2)
IF Y]""
SET AQAOS=$PIECE(^AQAO(7,Y,0),U,2)
QUIT
+5 SET (X,Y)=0
FOR
SET X=$ORDER(^AQAOC(AQAON,"REV",X))
IF X'=+X
QUIT
SET Y=X
+6 ;else get finding for last review
IF Y>0
Begin DoDot:1
+7 SET X=$PIECE(^AQAOC(AQAON,"REV",Y,0),U,5)
IF X]""
SET AQAOF=$PIECE(^AQAO(8,X,0),U,2)
+8 SET X=$PIECE(^AQAOC(AQAON,"REV",Y,0),U)
IF X]""
SET AQAOS=$PIECE(^AQAO(7,X,0),U,2)
End DoDot:1
QUIT
+9 ; ;else get initial finding
+10 SET X=$PIECE($GET(^AQAOC(AQAON,1)),U,5)
IF X]""
SET AQAOF=$PIECE(^AQAO(8,X,0),U,2)
+11 SET X=$PIECE($GET(^AQAOC(AQAON,1)),U,3)
IF X]""
SET AQAOS=$PIECE(^AQAO(7,X,0),U,2)
+12 QUIT
+13 ;
+14 ;
HDG1 ; >> SUBRTN for second half of heading
+1 SET X="(OCCURRENCE LISTINGS)"
WRITE ?AQAOIOMX-$LENGTH(X)/2,X
+2 WRITE !?AQAOIOMX-$LENGTH(AQAORG)/2,AQAORG,!,AQAOLINE
+3 WRITE !,"Case #",?9,"Occ Date",?23,"Age",?29,"Sex",?34,"Fndg/Stg"
+4 WRITE ?45,"Prov",?53,"Diagnoses",?92,"Procedures"
+5 WRITE !,AQAOLINE,!
+6 IF AQAODESC]""
WRITE !?AQAOIOMX-$LENGTH(AQAODESC)/2,AQAODESC,!
+7 QUIT
+8 ;
+9 ;
DLMHDG ; >> SUBRTN for ASCII heading for listing portion
+1 WRITE !!!!,"***OCCURRENCE LISTINGS WITH ICD CODES***",!,AQAORG,!
+2 WRITE !,"Printed by ",AQAODUZ," Printed on "
SET %H=$HOROLOG
DO YX^%DTC
WRITE Y
+3 IF AQAODESC]""
WRITE !,AQAODESC,!
+4 FOR I="Case #","Occ Date","Age","Sex","Finding","Stage"
WRITE I,AQAODLM
+5 FOR I="Provider","DX code","DX narrative","Procedure code","Procedure narrative"
WRITE I,AQAODLM
+6 QUIT
