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

APCL8A1.m

Go to the documentation of this file. 
  1. APCL8A1 ; IHS/CMI/LAB - Process APC 8A report ;
  1.  ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
  1.  ;
  1.  ;cmi/anch/maw 9/7/2007 code set verisioning in CHKPV
  1.  ;
  1. START ;
  1.  S APCLBT=$H,APCLJOB=$J
  1.  K ^XTMP("APCL8A",APCLJOB,APCLBT)
  1.  D XTMP^APCLOSUT("APCL8A","PCC VISITS NOT EXPORTED")
  1.  S X1=APCLFY,X2=-1 D C^%DTC S APCLSD=X S X1=APCLFY,X2=365 D C^%DTC S APCLFYE=$E(X,1,3)_"0930"
  1. V ; Run by visit date
  1.  S APCLGRAN=0
  1.  S APCLSD=APCLSD_".9999" F  S APCLSD=$O(^AUPNVSIT("B",APCLSD)) Q:APCLSD=""!((APCLSD\1)>APCLFYE)  D V1
  1. XIT ;
  1.  D EOJ
  1.  S APCLET=$H
  1.  Q
  1. V1 ;
  1.  S APCLVDFN="" F  S APCLVDFN=$O(^AUPNVSIT("B",APCLSD,APCLVDFN)) Q:APCLVDFN'=+APCLVDFN  I $D(^AUPNVSIT(APCLVDFN,0)) S APCLVREC=^(0) D PROC,EOJ
  1.  Q
  1. PROC ;
  1.  ;K APCLSKIP
  1.  ;Q:'$P(APCLVREC,U,9)
  1.  ;Q:$P(APCLVREC,U,11)
  1.  ;Q:"AORS"'[$P(APCLVREC,U,7)
  1.  ;Q:$D(^APCLCNTL(4,11,"B",$P(APCLVREC,U,3)))
  1.  I APCLLOC]"",APCLLOC'=$P(APCLVREC,U,6) Q
  1.  S DFN=$P(APCLVREC,U,5)
  1.  Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))  ;IHS/CMI/LAB - all demo patients
  1.  ;Q:'$D(^AUPNVPOV("AD",APCLVDFN))
  1.  ;Q:'$D(^AUPNVPRV("AD",APCLVDFN))
  1.  S APCLVLOC=$P(APCLVREC,U,6)
  1.  Q:'$D(^DIC(4,APCLVLOC))
  1.  Q:'$D(^AUTTLOC(APCLVLOC))
  1.  ;S APCLCLIN=$P(APCLVREC,U,8) I APCLCLIN="" S APCLCLIN=25 G PROC1
  1. CHKCL ;
  1.  ;S APCLX=$S(APCLCLIN="":"",$D(^DIC(40.7,APCLCLIN,0)):$P(^DIC(40.7,APCLCLIN,0),U,2),1:"")
  1.  ;Q:APCLX=""
  1.  ;Q:$D(^APCLCNTL(2,11,"B",APCLX))
  1.  ;I APCLX=56,'$D(^AUPNVMED("AD",APCLVDFN)) Q
  1. PROC1 ;
  1.  ;S (APCL1,APCL2)=0 F  S APCL2=$O(^AUPNVPRV("AD",APCLVDFN,APCL2)) Q:APCL2=""  I $P(^AUPNVPRV(APCL2,0),U,4)="P" S APCL1=APCL1+1,APCLAP=$P(^(0),U)
  1.  ;Q:APCL1=0
  1.  ;Q:APCL1>1
  1.  ;S APCLDISC="" D CHKDISC
  1.  ;Q:$D(APCLSKIP)
  1.  ;S APCLPPOV=$O(^AUPNVPOV("AD",APCLVDFN,""))
  1.  Q:'$$APCWL^APCLV(APCLVDFN)
  1.  S APCLMOS=+$E(APCLSD,4,5)
  1.  S APCLGRAN=APCLGRAN+1
  1.  I $P($G(^AUPNVSIT(APCLVDFN,11)),U,6)="" D
  1.  .S ^("NO EXPORT")=$S($D(^XTMP("APCL8A",APCLJOB,APCLBT,"NO EXPORT")):^("NO EXPORT")+1,1:1)
  1.  .I $D(^AUPNVSIT("ADWO",$P(APCLVREC,U,2),APCLVDFN)) S ^("IN XREF")=$S($D(^XTMP("APCL8A",APCLJOB,APCLBT,"IN XREF")):^("IN XREF")+1,1:1) Q
  1.  .I $D(^AUPNVSIT("ADWO",$P($P(APCLVREC,U,13),"."),APCLVDFN)) S ^("IN XREF")=$S($D(^XTMP("APCL8A",APCLJOB,APCLBT,"IN XREF")):^("IN XREF")+1,1:1) Q
  1.  .D ERRORCK
  1.  Q
  1. EOJ K APCLVLOC,APCLVREC,APCLCLIN,APCLSKIP,APCL1,APCL2,APCLAP,APCLDISC,APCLPPOV,APCLDPTR,APCLLOCC,APCLX
  1.  K X,X1,X2
  1.  Q
  1. ERRORCK ;
  1.  S DFN=$P(APCLVREC,U,5)
  1.  I $P(^DPT(DFN,0),U,2)="" S ^XTMP("APCL8A",APCLJOB,APCLBT,"VISITS",APCLVDFN)="Missing SEX of Patient" Q
  1.  I $P(^DPT(DFN,0),U,3)="" S ^XTMP("APCL8A",APCLJOB,APCLBT,"VISITS",APCLVDFN)="Missing DOB of Patient" Q
  1. COMM ;
  1.  S APCLCOMX=0,APCLCOMP="" F  S APCLCOMX=$O(^AUPNPAT(DFN,51,APCLCOMX)) Q:APCLCOMX'=+APCLCOMX  S APCLCOMP=APCLCOMX
  1.  I APCLCOMP="" S ^XTMP("APCL8A",APCLJOB,APCLBT,"VISITS",APCLVDFN)="No Community of Residence" Q
  1.  S APCLCOMP=$P(^AUPNPAT(DFN,51,APCLCOMP,0),U,3) I APCLCOMP="" S ^XTMP("APCL8A",APCLJOB,APCLBT,"VISITS",APCLVDFN)="No Community of Residence" Q
  1.  I '$D(^AUTTCOM(APCLCOMP,0)) S ^XTMP("APCL8A",APCLJOB,APCLBT,"VISITS",APCLVDFN)="Bad Community Pointer" Q
  1.  I APCLCOMP]"",$P(^AUTTCOM(APCLCOMP,0),U,8)="" S ^XTMP("APCL8A",APCLJOB,APCLBT,"VISITS",APCLVDFN)="Community in Table Missing code" Q
  1. TRIBE ;
  1.  I '$D(^AUPNPAT(DFN,11)) S ^XTMP("APCL8A",APCLJOB,APCLBT,"VISITS",APCLVDFN)="No Tribe of Membership" Q
  1.  S X=$P(^AUPNPAT(DFN,11),U,8) I X="" S ^XTMP("APCL8A",APCLJOB,APCLBT,"VISITS",APCLVDFN)="No Tribe of Membership" Q
  1.  I $P(^AUTTTRI(X,0),U,4)="Y" S ^XTMP("APCL8A",APCLJOB,APCLBT,"VISITS",APCLVDFN)="Old/Unused Tribe Code" Q
  1.  I $P(^AUTTTRI(X,0),U,2)="" S ^XTMP("APCL8A",APCLJOB,APCLBT,"VISITS",APCLVDFN)="Tribe Code Missing" Q
  1.  D CHKPV
  1.  Q:$D(^XTMP("APCL8A",APCLJOB,APCLBT,"VISITS",APCLVDFN))
  1.  S ^XTMP("APCL8A",APCLJOB,APCLBT,"VISITS",APCLVDFN)="UNKNOWN WHY NOT EXPORTED"
  1.  Q
  1. CHKPV ;
  1.  NEW X,E,P,I
  1.  ;S X=0 F  S X=$O(^AUPNVPOV("AD",APCLVDFN,X)) Q:X'=+X  S P=$P(^AUPNVPOV(X,0),U),I=$P(^ICD9(P,0),U) D  ;cmi/anch/maw 9/7/2007 orig line
  1.  ;cmi/anch/maw 9/7/2007 mods for code set versioning
  1.  N APCLVDT
  1.  S APCLVDT=+$P($G(^AUPNVSIT(APCLVDFN,0)),".")
  1.  ;cmi/anch/maw 9/7/2007 end of mods
  1.  S X=0 F  S X=$O(^AUPNVPOV("AD",APCLVDFN,X)) Q:X'=+X  S P=$$VALI^XBDIQ1(9000010.07,X,.01),I=$$VAL^XBDIQ1(9000010.07,X,.01) D
  1.  .I $$CAUSE^APCDAPOV(P,$$IMP^AUPNSICD($$VD^APCLV(APCLVDFN))) S ^XTMP("APCL8A",APCLJOB,APCLBT,"VISITS",APCLVDFN)="Cause of Injury used a diagnosis" Q
  1.  .I I=.9999!(I="ZZZ.999") S ^XTMP("APCL8A",APCLJOB,APCLBT,"VISITS",APCLVDFN)="Uncoded DX code used as POV" Q
  1.  .;I $P(^ICD9(P,0),U,9)]"" S ^XTMP("APCL8A",APCLJOB,APCLBT,"VISITS",APCLVDFN)="Inactive ICD code used" Q
  1.  .;I $L($P(I,".",2))>2 S ^XTMP("APCL8A",APCLJOB,APCLBT,"VISITS",APCLVDFN)="Invalid 6 digit ICD code used" Q
  1.  .Q
  1.  Q
  1. CHKDISC ;
  1.  I $P(^DD(9000010.06,.01,0),U,2)[6 G CHKDISC6 ;if not converted to 200 check file 6
  1.  I '$D(^VA(200,APCLAP)) S APCLSKIP=1 Q
  1.  S APCLDPTR=$$PROVCLS^XBFUNC1(APCLAP,"I") I APCLDPTR=""!(APCLDPTR="UNKNOWN") S APCLDISC="???" Q
  1.  S APCLDISC=$$PROVCLSC^XBFUNC1(APCLAP) I APCLDISC="UNKNOWN"!(APCLDISC="") S APCLSKIP=1 Q
  1.  S APCLLOCC=$E($P(^AUTTLOC(APCLVLOC,0),U,10),5,6)
  1.  I (APCLDISC=13!(APCLDISC=32))&((APCLLOCC>49)!(APCLLOCC'=+APCLLOCC)) S APCLSKIP=1
  1.  Q
  1. CHKDISC6 ;
  1.  I '$D(^DIC(6,APCLAP)) S APCLSKIP=1 Q
  1.  S APCLDPTR=$P(^DIC(6,APCLAP,0),U,4)
  1.  I APCLDPTR="" S APCLDISC="??" Q
  1.  I '$D(^DIC(7,APCLDPTR,9999999)) S APCLDISC="??" Q
  1.  S APCLDISC=$P(^DIC(7,APCLDPTR,9999999),U) I APCLDISC="" S APCLSKIP=1 Q
  1.  S APCLLOCC=$E($P(^AUTTLOC(APCLVLOC,0),U,10),5,6)
  1.  I (APCLDISC=13!(APCLDISC=32))&((APCLLOCC>49)!(APCLLOCC'=+APCLLOCC)) S APCLSKIP=1
  1.  Q