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

AQAOPC42.m

Go to the documentation of this file. 
  1. AQAOPC42 ; IHS/ORDC/LJF - OCC WITH FINDINGS/ACTIONS ;
  1.  ;;1.01;QAI MANAGEMENT;;OCT 05, 1995
  1.  ;
  1.  ;This rtn prints the trending report for occurrences with finding and
  1.  ;action data, subtotaling each.
  1.  ;
  1. INIT ; >>> initialize variables
  1.  D INIT^AQAOUTIL S AQAOHCON="Patient"
  1.  S AQAOTY="OCCURRENCES WITH FINDINGS & ACTIONS"
  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("AQAOPC4",$J)) D HEADING^AQAOUTIL,HDG1 W !!,"NO DATA FOUND FOR DATE RANGE SPECIFIED",!! G END
  1.  D LISTING
  1.  I AQAOSTOP'=U D SUMMARY^AQAOPC43
  1.  ;
  1. END ; >>> eoj
  1.  I $D(AQAODLM) W !!,*7,"*** STOP CAPTURE NOW! ***",!
  1.  D ^%ZISC I '$D(ZTQUEUED) D PRTOPT^AQAOVAR
  1.  K ^TMP("AQAOPC4",$J),^TMP("AQAO",$J)
  1.  D KILL^AQAOUTIL 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("AQAOPC4",$J,AQAOSUB)) Q:AQAOSUB=""  Q:AQAOSTOP=U  D LIST2 ;spec review sort
  1.  Q
  1.  ;
  1.  ;
  1. LIST2 ; >> SUBRTN for each AQAOSUB list occ with find/actions
  1.  I AQAOSUB'=0 W:AQAOTYPE="L" !!?AQAOIOMX-$L(AQAOSUB)/2,AQAOSUB,!
  1.  S AQAODT=0
  1.  F  S AQAODT=$O(^TMP("AQAOPC4",$J,AQAOSUB,AQAODT)) Q:AQAODT=""  Q:AQAOSTOP=U  D
  1.  .S AQAON=0
  1.  .F  S AQAON=$O(^TMP("AQAOPC4",$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.  ...W:$D(AQAODLM) AQAODLM W:'$D(AQAODLM) ?35
  1.  ...W $S(+^AQAOC(AQAON,1)=0:"OPEN",1:"CLOSED") ;case status
  1.  ..;
  1.  ..D FINDING
  1.  ..;print last stage
  1.  ..I AQAOTYPE="L" W:$D(AQAODLM) AQAODLM W:'$D(AQAODLM) ?45 W AQAOS
  1.  ..;print last finding
  1.  ..I AQAOTYPE="L" W:$D(AQAODLM) AQAODLM W:'$D(AQAODLM) ?55 W AQAOF
  1.  ..;print last action
  1.  ..I AQAOTYPE="L" W:$D(AQAODLM) AQAODLM W:'$D(AQAODLM) ?65 W AQAOG
  1.  Q
  1.  ;
  1.  ;
  1. FINDING ; >> SUBRTN to find last finding to date for occ
  1.  S (AQAOF,AQAOS,AQAOG,X,Y,Z)="" ;init finding/stage/action to null
  1.  I $P(^AQAOC(AQAON,1),U)=1 D  ;closed occurrences
  1.  .S X=$P($G(^AQAOC(AQAON,"FINAL")),U,4) S:X="" X="??" ;finding
  1.  .S Y=$P($G(^AQAOC(AQAON,"FINAL")),U,2) S:Y="" Y="??" ;stage
  1.  .S Z=$P($G(^AQAOC(AQAON,"FINAL")),U,6) S:Z="" Z="??" ;action
  1.  ;
  1.  I X]"" G COUNT
  1.  S (X,AQAOY)=0 F  S X=$O(^AQAOC(AQAON,"REV",X)) Q:X'=+X  S AQAOY=X
  1.  I AQAOY>0 D  ;else get finding for last review
  1.  .S X=$P(^AQAOC(AQAON,"REV",AQAOY,0),U,5)
  1.  .S Y=$P(^AQAOC(AQAON,"REV",AQAOY,0),U)
  1.  .S Z=$P(^AQAOC(AQAON,"REV",AQAOY,0),U,7)
  1.  G COUNT:X]""
  1.  ;else get initial finding and action
  1.  S X=$P($G(^AQAOC(AQAON,1)),U,5)
  1.  S Y=$P($G(^AQAOC(AQAON,1)),U,3)
  1.  S Z=$P($G(^AQAOC(AQAON,1)),U,6)
  1.  ;
  1. COUNT ;increment counts
  1.  I X="??" D
  1.  .S AQAOF=X
  1.  .S ^TMP("AQAO",$J,"F",AQAOSUB,X)=$G(^TMP("AQAO",$J,"F",AQAOSUB,X))+1
  1.  E  D
  1.  .S AQAOF=$P(^AQAO(8,X,0),U,2)
  1.  .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
  1.  S AQAOS=$S(Y="??":Y,1:$P(^AQAO(7,Y,0),U,2))
  1.  ;
  1.  I Z="??" D
  1.  .S AQAOG=Z
  1.  .S ^TMP("AQAO",$J,"A",AQAOSUB,Z)=$G(^TMP("AQAO",$J,"A",AQAOSUB,Z))+1
  1.  E  D
  1.  .S AQAOG=$P(^AQAO(6,Z,0),U,2)
  1.  .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
  1.  Q
  1.  ;
  1.  ;
  1. HDG1 ; >> SUBRTN for second half of heading
  1.  W ?30,"(OCCURRENCE LISTINGS)",!?30,AQAORG,!,AQAOLINE
  1.  W !,"Case #",?9,"Occ Date",?23,"Age",?29,"Sex",?35,"Status",?45,"Stage"
  1.  W ?55,"Findings",?65,"Actions"
  1.  W !,AQAOLINE
  1.  S X="** "_$P(^AQAO(2,AQAOIND,0),U)_"   "_$P(^(0),U,2)_" **"
  1.  W !!?AQAOIOMX-$L(X)/2,X,! ;indicator # and name
  1.  Q
  1.  ;
  1.  ;
  1. HDG2 ; >> SUBRTN for second half of heading2    
  1.  W ?33,"(SUMMARY PAGE)",!?30,AQAORG,!,AQAOLINE,!
  1.  Q
  1.  ;
  1.  ;
  1. DLMHDG ; >> SUBRTN for ASCII heading for listing portion
  1.  W !!!!,"***OCCURRENCE LISTINGS WITH FINDINGS & ACTIONS***",!,AQAORG,!
  1.  W !,"Printed by ",AQAODUZ," Printed on " S %H=$H D YX^%DTC W Y
  1.  F I="Case #","Occ Date","Age","Sex","Status","Stage","Finding","Action" W I,AQAODLM
  1.  Q