Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AQAOPC22

AQAOPC22.m

Go to the documentation of this file. 
  1. AQAOPC22 ; IHS/ORDC/LJF - PRINT OCC BY INDICATOR W/ ICD ;
  1.  ;;1.01;QAI MANAGEMENT;;OCT 05, 1995
  1.  ;
  1.  ;This rtn is the main driver to print the trending report by diagnosis
  1.  ;and procedure.
  1.  ;
  1. INIT ; >>> initialize variables
  1.  I AQAOTYPE="L",IOT'="HFS" D
  1.  .S (AQAOIOMX,X)=132 X ^%ZOSF("RM") ;lstng needs 132col
  1.  D INIT^AQAOUTIL S AQAOHCON="Patient"
  1.  S AQAOTY="OCCURRENCES BY INDICATOR WITH DX/PROCEDURES"
  1.  S AQAORG=$E(AQAOBD,4,5)_"/"_$E(AQAOBD,6,7)_"/"_$E(AQAOBD,2,3)_" to "
  1.  S AQAORG=AQAORG_$E(AQAOED,4,5)_"/"_$E(AQAOED,6,7)_"/"_$E(AQAOED,2,3)
  1.  K ^TMP("AQAO",$J)
  1.  ;
  1. MAIN ; >>> main calls
  1.  I '$D(^TMP("AQAOPC2",$J)) D HEADING^AQAOUTIL,HDG1 W !!,"NO DATA FOR DATE RANGE SPECIFIED",!! G END ;no entries
  1.  D LISTING
  1.  I AQAOSTOP'=U D SUMMARY^AQAOPC24
  1.  ;
  1.  ;
  1. END ; >>> eoj
  1.  I $D(AQAODLM) W !!,*7,"*** STOP CAPTURE NOW! ***",!
  1.  I AQAOTYPE="L",IOT'="HFS" S X=IOM X ^%ZOSF("RM") ;reset right margin
  1.  D ^%ZISC I '$D(ZTQUEUED) D PRTOPT^AQAOVAR
  1.  K ^TMP("AQAOPC2",$J),^TMP("AQAO",$J) D KILL^AQAOUTIL
  1.  Q
  1.  ;
  1.  ;
  1. LISTING ; >> SUBRTN to print occurrence listing if selected
  1.  I $D(AQAODLM),AQAOTYPE="L" D DLMHDG I 1 ;print heading
  1.  E  I AQAOTYPE="L" D HEADING^AQAOUTIL,HDG1
  1.  ;
  1.  S AQAOSUB=0 I '$D(AQAOXSN) D LIST2 Q  ;no spec sorts
  1.  F  S AQAOSUB=$O(^TMP("AQAOPC2",$J,AQAOSUB)) Q:AQAOSUB=""  Q:AQAOSTOP=U  D LIST2 ;spec review sort
  1.  Q
  1.  ;
  1.  ;
  1. LIST2 ; >> SUBRTN to print occ for each AQAOSUB
  1.  I AQAOSUB'=0 W:AQAOTYPE="L" !!?AQAOIOMX-$L(AQAOSUB)/2,AQAOSUB,!
  1.  S AQAODT=0
  1.  F  S AQAODT=$O(^TMP("AQAOPC2",$J,AQAOSUB,AQAODT)) Q:AQAODT=""  Q:AQAOSTOP=U  D
  1.  .S AQAON=0
  1.  .F  S AQAON=$O(^TMP("AQAOPC2",$J,AQAOSUB,AQAODT,AQAON)) Q:AQAON=""  Q:AQAOSTOP=U  D
  1.  ..S AQAOSTR=$G(^AQAOC(AQAON,0)) ;basic occ data
  1.  ..I AQAOTYPE="L" D
  1.  ...I '$D(AQAODLM),($Y>(IOSL-2)) D NEWPG^AQAOUTIL Q:AQAOSTOP=U  D HDG1
  1.  ...S Y=AQAODT X ^DD("DD") I $D(AQAODLM) S Y=$P(Y,",")_" "_$P(Y,",",2)
  1.  ...I $D(AQAODLM) W !,$P(AQAOSTR,U),AQAODLM,Y,AQAODLM ;case&date ASCII
  1.  ...E  W !,$P(AQAOSTR,U),?9,Y ;print case & date
  1.  ...K ^UTILITY("DIQ1",$J) S DIC="^AQAOC(",DA=AQAON,DR=".025" D EN^DIQ1
  1.  ...W:'$D(AQAODLM) ?22
  1.  ...W ^UTILITY("DIQ1",$J,9002167,AQAON,.025) ;age at time of occ
  1.  ...W:$D(AQAODLM) AQAODLM W:'$D(AQAODLM) ?30
  1.  ...W $P(^DPT($P(^AQAOC(AQAON,0),U,2),0),U,2) ;patient's sex
  1.  ..;
  1.  ..D FINDING
  1.  ..;print last finding
  1.  ..I AQAOTYPE="L" W:$D(AQAODLM) "," W:'$D(AQAODLM) ?35
  1.  ..I AQAOTYPE="L" W AQAOF,$S($D(AQAODLM):AQAODLM,AQAOS="":"",1:" / "),AQAOS
  1.  ..;increment count for this finding
  1.  ..I AQAOF]"" S ^TMP("AQAO",$J,"F",AQAOSUB,AQAOF)=$G(^TMP("AQAO",$J,"F",AQAOSUB,AQAOF))+1
  1.  ..;
  1.  ..D ICDPRINT^AQAOPC23 ;print all icd codes defined for occ
  1.  Q
  1.  ;
  1.  ;
  1. FINDING ; >> SUBRTN to find last finding to date for occ
  1.  S (AQAOF,AQAOS)="" ;initialize finding & stage to null
  1.  S X=$P($G(^AQAOC(AQAON,"FINAL")),U,4) ;if final finding at closure
  1.  S Y=$P($G(^AQAOC(AQAON,"FINAL")),U,2) ;final review stage
  1.  I X]"" S AQAOF=$P(^AQAO(8,X,0),U,2) S:Y]"" AQAOS=$P(^AQAO(7,Y,0),U,2) Q
  1.  S (X,Y)=0 F  S X=$O(^AQAOC(AQAON,"REV",X)) Q:X'=+X  S Y=X
  1.  I Y>0 D  Q  ;else get finding for last review
  1.  .S X=$P(^AQAOC(AQAON,"REV",Y,0),U,5) S:X]"" AQAOF=$P(^AQAO(8,X,0),U,2)
  1.  .S X=$P(^AQAOC(AQAON,"REV",Y,0),U) S:X]"" AQAOS=$P(^AQAO(7,X,0),U,2)
  1.  ;           ;else get initial finding
  1.  S X=$P($G(^AQAOC(AQAON,1)),U,5) S:X]"" AQAOF=$P(^AQAO(8,X,0),U,2)
  1.  S X=$P($G(^AQAOC(AQAON,1)),U,3) S:X]"" AQAOS=$P(^AQAO(7,X,0),U,2)
  1.  Q
  1.  ;
  1.  ;
  1. HDG1 ; >> SUBRTN for second half of heading
  1.  S X="(OCCURRENCE LISTINGS)" W ?AQAOIOMX-$L(X)/2,X
  1.  W !?AQAOIOMX-$L(AQAORG)/2,AQAORG,!,AQAOLINE
  1.  W !,"Case #",?9,"Occ Date",?23,"Age",?29,"Sex",?34,"Fndg/Stg"
  1.  W ?45,"Prov",?53,"Diagnoses",?92,"Procedures"
  1.  W !,AQAOLINE,!
  1.  I AQAODESC]"" W !?AQAOIOMX-$L(AQAODESC)/2,AQAODESC,!
  1.  Q
  1.  ;
  1.  ;
  1. DLMHDG ; >> SUBRTN for ASCII heading for listing portion
  1.  W !!!!,"***OCCURRENCE LISTINGS WITH ICD CODES***",!,AQAORG,!
  1.  W !,"Printed by ",AQAODUZ," Printed on " S %H=$H D YX^%DTC W Y
  1.  I AQAODESC]"" W !,AQAODESC,!
  1.  F I="Case #","Occ Date","Age","Sex","Finding","Stage" W I,AQAODLM
  1.  F I="Provider","DX code","DX narrative","Procedure code","Procedure narrative" W I,AQAODLM
  1.  Q