source: WorldVistAEHR/trunk/r/SPINAL_CORD_DYSFUNCTION-SPN/SPNAGGE.m@ 824

SPNAGGE ;SD/CM- AGGREGATE ANUAL EVAL OUTCOMES REPORT; 2-21-2003
 ;;2.0;Spinal Cord Dysfunction;**20,21**;01/02/97
 ;
EN ;
 S U="^"
 D SET^SPNAGGEU
PARAMS ;
 D CED
 G:SPNLEXIT=1 EXIT
DEVICE ;
 S ZTSAVE("SPN*")="",ZTSAVE("B*")="",ZTSAVE("AGE*")="",ZTSAVE("MIN*")=""
 S ZTSAVE("MAX*")="",ZTSAVE("LOR*")="",ZTSAVE("TF*")="",ZTSAVE("SEX*")=""
 S ZTSAVE("SL*")="",ZTSAVE("CARETYP")="",ZTSAVE("MF*")=""
 S ZTSAVE("EDATE")="",ZTSAVE("BDATE")="",ZTSAVE("LINE")="",ZTSAVE("I")=""
 S ZTSAVE("ASIA*")="",ZTSAVE("C*")=""
 W !
 D DEVICE^SPNPRTMT("PRINT^SPNAGGPE","Annual Eval Outcomes",.ZTSAVE) Q:SPNLEXIT
 I SPNIO="Q" D EXIT Q  ; Print was queued
 I IO'="" D PRINT^SPNAGGPE D EXIT Q  ; Print was not queued
 D EXIT
 Q
CED ;date range for Record Date
 D DATE^SPNAGGA
 Q
OIEN ;
 S SPNPD1=0 F  S SPNPD1=$O(^SPNL(154.1,"B",SPNPD0,SPNPD1)) Q:'+SPNPD1  D DIAGCAT
 Q
DIAGCAT ;get ASIA Highest Neuro Level and ASIA Imp Scale
 S SPNDCS=0,SPNDCM=0,SPNDCP=0,SPNDCL=0
 Q:'$D(^SPNL(154.1,SPNPD1,0))
 Q:'$D(^SPNL(154.1,SPNPD1,"ASIA"))
 Q:'$D(^SPNL(154.1,SPNPD1,8))
 Q:$P(^SPNL(154.1,SPNPD1,0),U,2)'=3
 Q:$P(^SPNL(154.1,SPNPD1,8),U,3)'=CARETYP
 Q:$P($G(^SPNL(154.1,SPNPD1,0)),U,4)<BDATE!($P($G(^SPNL(154.1,SPNPD1,0)),U,4)>EDATE)
 Q:$P($G(^SPNL(154.1,SPNPD1,0)),U,1)=SPNNODUP
 S SPNNODUP=$P($G(^SPNL(154.1,SPNPD1,0)),U,1)
 S ASIAONE=$P($G(^SPNL(154.1,SPNPD1,"ASIA")),U,1),ASIAFRTN=$P($G(^SPNL(154.1,SPNPD1,"ASIA")),U,14)
 I "ABC"[ASIAONE,ASIAFRTN<5 S SPNDCS=1
 I "ABC"[ASIAONE,ASIAFRTN<5 S SPNLSTDT="S"
 I "ABC"[ASIAONE&(ASIAFRTN>4)&(ASIAFRTN<9) S SPNDCM=1
 I "ABC"[ASIAONE&(ASIAFRTN>4)&(ASIAFRTN<9) S SPNLSTDT="M"
 I "ABC"[ASIAONE,ASIAFRTN>8 S SPNDCP=1
 I "ABC"[ASIAONE,ASIAFRTN>8 S SPNLSTDT="P"
 I ASIAONE="D",ASIAFRTN<31 S SPNDCL=1
 I ASIAONE="D",ASIAFRTN<31 S SPNLSTDT="L"
 I SPNLSTDT="S" S SPNSEVC=SPNSEVC+1
 I SPNLSTDT="M" S SPNMODC=SPNMODC+1
 I SPNLSTDT="P" S SPNPARC=SPNPARC+1
 I SPNLSTDT="L" S SPNLOWC=SPNLOWC+1
 S SPNDIAGC=SPNDIAGC+1
 ;
AGE ;
 S AGECALL=$$GET1^DIQ(154.1,SPNPD1,999.025)
 I +SPNDCS S SPNAGES=SPNAGES+AGECALL,AGESC=AGESC+1 S:AGESC=1 BMAS=AGECALL S MINAGES=$S(AGECALL<BMAS:AGECALL,1:BMAS)
 I +SPNDCS S:AGESC=1 BHAS=AGECALL S MAXAGES=$S(AGECALL>BHAS:AGECALL,1:BHAS)
 I +SPNDCM S SPNAGEM=SPNAGEM+AGECALL,AGEMC=AGEMC+1 S:AGEMC=1 BMAM=AGECALL S MINAGEM=$S(AGECALL<BMAM:AGECALL,1:BMAM)
 I +SPNDCM S:AGEMC=1 BHAM=AGECALL S MAXAGEM=$S(AGECALL>BHAM:AGECALL,1:BHAM)
 I +SPNDCP S SPNAGEP=SPNAGEP+AGECALL,AGEPC=AGEPC+1 S:AGEPC=1 BMAP=AGECALL S MINAGEP=$S(AGECALL<BMAP:AGECALL,1:BMAP)
 I +SPNDCP S:AGEPC=1 BHAP=AGECALL S MAXAGEP=$S(AGECALL>BHAP:AGECALL,1:BHAP)
 I +SPNDCL S SPNAGEL=SPNAGEL+AGECALL,AGELC=AGELC+1 S:AGELC=1 BMAL=AGECALL S MINAGEL=$S(AGECALL<BMAL:AGECALL,1:BMAL)
 I +SPNDCL S:AGELC=1 BHAL=AGECALL S MAXAGEL=$S(AGECALL>BHAL:AGECALL,1:BHAL)
 S AGEL=$S((MINAGES<MINAGEM)&(MINAGES<MINAGEP)&(MINAGES<MINAGEL):MINAGES,(MINAGEM<MINAGEP)&(MINAGEM<MINAGEL):MINAGEM,MINAGEP<MINAGEL:MINAGEP,1:MINAGEL)
 S AGEH=$S((MAXAGES>MAXAGEM)&(MAXAGES>MAXAGEP)&(MAXAGES>MAXAGEL):MAXAGES,(MAXAGEM>MAXAGEP)&(MAXAGEM>MAXAGEL):MAXAGEM,MAXAGEP>MAXAGEL:MAXAGEP,1:MAXAGEL)
 ;
SEX ;
 S SEXCALL=$P(^DPT($P(^SPNL(154.1,SPNPD1,0),U,1),0),U,2)
 I +SPNDCS,SEXCALL="M" S SPNSEXS=SPNSEXS+1
 I +SPNDCM,SEXCALL="M" S SPNSEXM=SPNSEXM+1
 I +SPNDCP,SEXCALL="M" S SPNSEXP=SPNSEXP+1
 I +SPNDCL,SEXCALL="M" S SPNSEXL=SPNSEXL+1
LOR ;Let's obtain record
 I +SPNDCS D STATS I +TFSRN S TFS=TFS+TFSCALL,TFCS=TFCS+1
 I +SPNDCS&(+MFSRN) S MFS=MFS+MFSCALL,MFCS=MFCS+1
 I +SPNDCS&(+CFSRN) S CFS=CFS+CFSCALL,CFCS=CFCS+1
 I +SPNDCS&(+CPIRN) S CPIS=CPIS+CPICALL,CPICS=CPICS+1
 I +SPNDCS&(+CCIRN) S CCIS=CCIS+CCICALL,CCICS=CCICS+1
 I +SPNDCS&(+CMRN) S CMS=CMS+CMCALL,CMCS=CMCS+1
 I +SPNDCS&(+CORN) S COS=COS+COCALL,COCS=COCS+1
 I +SPNDCS&(+CSIRN) S CSIS=CSIS+CSICALL,CSICS=CSICS+1
 I +SPNDCS&(+CERN) S CES=CES+CECALL,CECS=CECS+1
 I +SPNDCS&(+SLSRN) S SLSS=SLSS+SLSCALL,SLCS=SLCS+1
 ;
 I +SPNDCM D STATS I +TFSRN S TFM=TFM+TFSCALL,TFCM=TFCM+1
 I +SPNDCM&(+MFSRN) S MFM=MFM+MFSCALL,MFCM=MFCM+1
 I +SPNDCM&(+CFSRN) S CFM=CFM+CFSCALL,CFCM=CFCM+1
 I +SPNDCM&(+CPIRN) S CPIM=CPIM+CPICALL,CPICM=CPICM+1
 I +SPNDCM&(+CCIRN) S CCIM=CCIM+CCICALL,CCICM=CCICM+1
 I +SPNDCM&(+CMRN) S CMM=CMM+CMCALL,CMCM=CMCM+1
 I +SPNDCM&(+CORN) S COM=COM+COCALL,COCM=COCM+1
 I +SPNDCM&(+CSIRN) S CSIM=CSIM+CSICALL,CSICM=CSICM+1
 I +SPNDCM&(+CERN) S CEM=CEM+CECALL,CECM=CECM+1
 I +SPNDCM&(+SLSRN) S SLSM=SLSM+SLSCALL,SLCM=SLCM+1
 ;
 I +SPNDCP D STATS I +TFSRN S TFP=TFP+TFSCALL,TFCP=TFCP+1
 I +SPNDCP&(+MFSRN) S MFP=MFP+MFSCALL,MFCP=MFCP+1
 I +SPNDCP&(+CFSRN) S CFP=CFP+CFSCALL,CFCP=CFCP+1
 I +SPNDCP&(+CPIRN) S CPIP=CPIP+CPICALL,CPICP=CPICP+1
 I +SPNDCP&(+CCIRN) S CCIP=CCIP+CCICALL,CCICP=CCICP+1
 I +SPNDCP&(+CMRN) S CMP=CMP+CMCALL,CMCP=CMCP+1
 I +SPNDCP&(+CORN) S COP=COP+COCALL,COCP=COCP+1
 I +SPNDCP&(+CSIRN) S CSIP=CSIP+CSICALL,CSICP=CSICP+1
 I +SPNDCP&(+CERN) S CEP=CEP+CECALL,CECP=CECP+1
 I +SPNDCP&(+SLSRN) S SLSP=SLSP+SLSCALL,SLCP=SLCP+1
 ;
 I +SPNDCL D STATS I +TFSRN S TFL=TFL+TFSCALL,TFCL=TFCL+1
 I +SPNDCL&(+MFSRN) S MFL=MFL+MFSCALL,MFCL=MFCL+1
 I +SPNDCL&(+CFSRN) S CFL=CFL+CFSCALL,CFCL=CFCL+1
 I +SPNDCL&(+CPIRN) S CPIL=CPIL+CPICALL,CPICL=CPICL+1
 I +SPNDCL&(+CCIRN) S CCIL=CCIL+CCICALL,CCICL=CCICL+1
 I +SPNDCL&(+CMRN) S CML=CML+CMCALL,CMCL=CMCL+1
 I +SPNDCL&(+CORN) S COL=COL+COCALL,COCL=COCL+1
 I +SPNDCL&(+CSIRN) S CSIL=CSIL+CSICALL,CSICL=CSICL+1
 I +SPNDCL&(+CERN) S CEL=CEL+CECALL,CECL=CECL+1
 I +SPNDCL&(+SLSRN) S SLSL=SLSL+SLSCALL,SLCL=SLCL+1
 Q
 ;
STATS ;finds record
 S TFSRN=0,MFSRN=0,CFSRN=0,CPIRN=0,CCIRN=0,CMRN=0,CORN=0,CSIRN=0,CERN=0,SLSRN=0
 S V=SPNPD1 F  S V=$O(^SPNL(154.1,"B",SPNPD0,V)) Q:'+V  D GETLOR
 S TFSCALL=$$GET1^DIQ(154.1,TFSRN,999.05)
 S MFSCALL=$$GET1^DIQ(154.1,MFSRN,999.03)
 S CFSCALL=$$GET1^DIQ(154.1,CFSRN,999.04)
 S CPICALL=$P($G(^SPNL(154.1,CPIRN,"CHART")),U,1)
 S CCICALL=$P($G(^SPNL(154.1,CCIRN,"CHART")),U,6)
 S CMCALL=$P($G(^SPNL(154.1,CMRN,"CHART")),U,2)
 S COCALL=$P($G(^SPNL(154.1,CORN,"CHART")),U,3)
 S CSICALL=$P($G(^SPNL(154.1,CSIRN,"CHART")),U,4)
 S CECALL=$P($G(^SPNL(154.1,CERN,"CHART")),U,5)
 S SLSCALL=$P($G(^SPNL(154.1,SLSRN,"SCORE")),U,1)
 Q
GETLOR ;get Rec No. for TFS,MFS,CFS,CPI,SLS, etc
 Q:'$D(^SPNL(154.1,V,0))
 Q:$P($G(^SPNL(154.1,V,8)),U,3)'=CARETYP
 Q:$P($G(^SPNL(154.1,V,0)),U,4)<BDATE!($P($G(^SPNL(154.1,V,0)),U,4)>EDATE)
 I $P(^SPNL(154.1,V,0),U,2)=2 S (TFSRN,MFSRN,CFSRN)=V
 I $P(^SPNL(154.1,V,0),U,2)=4 S (CPIRN,CCIRN,CMRN,CORN,CSIRN,CERN)=V
 I $P(^SPNL(154.1,V,0),U,2)=6 S SLSRN=V
 Q
EXIT ;
 D EXIT^SPNAGGEU
 Q