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