APCDVCH ; IHS/CMI/LAB - EDIT HOSPITALIZATIONS ; 02 Nov 2015 11:43 AM
;;2.0;IHS PCC SUITE;**2,11,13**;MAY 14, 2009;Build 9
CHKHOSP ;
Q:'$O(^AUPNVINP("AD",APCDVSIT,""))
W !
D GETTS
Q:APCDTS=""
Q:APCDDS=""
D GETPOVS
I '$D(APCDVCPV("P")) W !,$C(7),"WARNING: No PRINCIPLE DX entered for this Hospitalization!",! D XIT Q
I APCD3>1 W !,$C(7),"WARNING: Multiple PRINCIPLE DXs entered for this Hospitalization!",! D XIT Q
D GETACC
S X2=AUPNDOB,X1=APCDDATE D ^%DTC S AUPNDAYS=X
D ^APCDVCH2
D CHECKPVS
D ^APCDVCH1
K APCDAGEE
S X=0 F S X=$O(^AUPNVPOV("AD",APCDVSIT,X)) Q:X'=+X S APCDICDP=$P(^AUPNVPOV(X,0),U),APCDICD=$$CODEC^ICDEX(80,APCDICDP) D
.K APCDAGEE
.I $$CHKE1^AUPNSICD(APCDICDP) W !,"External Cause code used for POV" Q
.I APCDICD=.9999!(APCDICD="ZZZ.999") W !,APCDICD_" Diagnosis used" Q
.S %=$$ICDDX^ICDEX(APCDICDP,$$VD^APCLV(APCDVSIT)) I $P(%,U,11)]"",AUPNSEX'=$P(%,U,11) W !,"Gender of Patient invalid for this ICD code "_APCDICD Q
.S (A,B)="" ;CSV
.I $$VERSION^XPDUTL("BCSV")]"" D I 1 ;CSV
..S A=$P(%,U,15),B=$P(%,U,16)
.E S A=$P($G(^ICD9(APCDICDP,9999999)),U),B=$P($G(^ICD9(APCDICDP,9999999)),U,2)
.I A,A>$$AGE^AUPNPAT($P($G(^AUPNVSIT(APCDVSIT,0)),U,5),$$VD^APCLV(APCDVSIT)) S APCDAGEE=""
.I B,B<$$AGE^AUPNPAT($P($G(^AUPNVSIT(APCDVSIT,0)),U,5),$$VD^APCLV(APCDVSIT)) S APCDAGEE=""
.I $P(APCDVREC,U,7)="H",'$D(^APCDINPT(9,11,"AC",APCDICD)),$D(APCDAGEE) W !,"WARNING: ICD code invalid for age, please review "_APCDICD Q
.I $D(APCDAGEE) W !,"Age invalid for this ICD code. PLEASE REVIEW: "_APCDICD Q
XIT ;
K APCDTS,APCDVINR,APCDDS,APCDIACC,APCD1,APCD2,APCD3,APCDPREC,APCDSC,APCDICD9,APCDVCPV,APCDACC,APCDDUPE,APCDDXP,APCDACCO,APCDDUPO,APCDOPP,APCDDX,APCDPX,APCDFOUN,APCDOPP,APCDOPC,APCDDXP,APCDDXC,APCDDXOP,APCDOPDX,APCDVCPS
K APCDE,APCDVCPV,APCDVPRC,APCDOP,APCDADM,APCDDIS,APCD3,APCDAGEE,A,B,%
Q
GETTS ;
S APCDVINR=$O(^AUPNVINP("AD",APCDVSIT,"")),APCDVINR=^AUPNVINP(APCDVINR,0),APCDTS=$P(APCDVINR,U,4),APCDDS=$P(APCDVINR,U,5)
I APCDTS="" W !,$C(7),"WARNING: Admitting Service Missing",! Q
I APCDDS="" W !,$C(7),"WARNING: Discharge Service Missing",! Q
S APCDTS=$P(^DIC(45.7,APCDTS,9999999),U),APCDDS=$P(^DIC(45.7,APCDDS,9999999),U)
I APCDTS="" W !,$C(7),"WARNING: Admitting Service Code Missing",!
I APCDDS="" W !,$C(7),"WARNING: Discharge Service Code Missing",!
Q
GETACC ;
S APCDACC="" ;ACCEPT COMMAND NO LONGER NECESSARY FOR EXPORT
Q
GETPOVS ;
S (APCD1,APCD2,APCD3)=0 F S APCD2=$O(^AUPNVPOV("AD",APCDVSIT,APCD2)) Q:APCD2="" S APCD1=APCD1+1 D SETPOV
Q
SETPOV ;
S APCDPREC=^AUPNVPOV(APCD2,0),APCDSC=$P(APCDPREC,U,12) S:APCDSC="" APCDSC="S"
I APCDSC="P" S APCD3=APCD3+1,APCDVCPV("P")=$$CODEC^ICDEX(80,$P(APCDPREC,U))_"^"_$P(APCDPREC,U)_"^"_APCD2 Q
S APCDVCPV(APCDSC,APCD1)=$$CODEC^ICDEX(80,$P(APCDPREC,U))_"^"_$P(APCDPREC,U)_"^"_APCD2
Q
CHECKPVS ;
C2 ;CERTAIN "V" CODES CANNOT BE PRIM DXS
I $D(^APCDINPT(2,11,"AC",$P(APCDVCPV("P"),U))) W !,$C(7),"WARNING: Diagnosis Code ",$P(APCDVCPV("P"),U)," cannot be used as a PRIMARY DX! Please review.",!
C1 ;IF PRIM DX IS A "V" CODE SEC MUST BE "V" CODE ALSO
;WITH EXCEPTIONS
;I $E($P(APCDVCPV("P"),U))="V",'$D(^APCDINPT(1,11,"AC",$P(APCDVCPV("P"),U))) D C11
E1 ;CERTAIN CODES REQUIRE AN ACCEPT COMMAND
I $D(^APCDINPT(8,11,"AC",$P(APCDVCPV("P"),U))),'$D(APCDACC) S APCDICD9=$P(APCDVCPV("P"),U) D E1W
S APCD1=0 F S APCD1=$O(APCDVCPV("S",APCD1)) Q:APCD1'=+APCD1 D E11
;
E2 ;IF CODE V30-V39 (.0) ADM SRV MUST BE NEWBORN
I $D(^APCDINPT(4,"AC",$P(APCDVCPV("P"),U))),APCDTS'="07" W !,$C(7),"WARNING: Primary DX is ",$P(APCDVCPV("P"),U)," therefore Admitting Service must",!,"be NEWBORN (07)!",! Q
E3 ;IF PRIM DX IS V30-V39(.1) ADM SRV MUST BE ,11
;I $D(^APCDINPT(3,11,"AC",$P(APCDVCPV("P"),U))),APCDTS'=11 W !,$C(7),"WARNING: Primary DX is ",$P(APCDVCPV("P"),U)," therefore Admitting Service must",!,"be PEDIATRICS (11)!",! Q
E4 ;IF PRIM DX (V30-V39 (.0 OR ,.1)) AGE CANNOT BE > 3 DAYS
I (($D(^APCDINPT(4,11,"AC",$P(APCDVCPV("P"),U))))!($D(^APCDINPT(3,11,"AC",$P(APCDVCPV("P"),U))))),AUPNDAYS>3 W !,$C(7),"WARNING: Primary DX is ",$P(APCDVCPV("P"),U)," therefore Age of Patient cannot be",!,"greater than 3 days!",! Q
Q
E11 ;
I $D(^APCDINPT(8,11,"AC",$P(APCDVCPV("S",APCD1),U))),'$D(APCDACC) S APCDICD9=$P(APCDVCPV("S",APCD1),U) D E1W
Q
E1W ;
W !,$C(7),"WARNING: You have used ICD code ",APCDICD9,", please review with Your Supervisor.",! Q
Q
C11 ;
;S APCD1=0 F S APCD1=$O(APCDVCPV("S",APCD1)) Q:APCD1'=+APCD1 D C12
Q
C12 ;
;I $E($P(APCDVCPV("S",APCD1),U))'="V" W !,$C(7),"WARNING: The primary POV for this Hospitalization is a V Code, therefore",!,"the Secondary POVs must be V codes. Please correct this Visit.",!
Q
APCDVCH ; IHS/CMI/LAB - EDIT HOSPITALIZATIONS ; 02 Nov 2015 11:43 AM
+1 ;;2.0;IHS PCC SUITE;**2,11,13**;MAY 14, 2009;Build 9
CHKHOSP ;
+1 IF '$ORDER(^AUPNVINP("AD",APCDVSIT,""))
QUIT
+2 WRITE !
+3 DO GETTS
+4 IF APCDTS=""
QUIT
+5 IF APCDDS=""
QUIT
+6 DO GETPOVS
+7 IF '$DATA(APCDVCPV("P"))
WRITE !,$CHAR(7),"WARNING: No PRINCIPLE DX entered for this Hospitalization!",!
DO XIT
QUIT
+8 IF APCD3>1
WRITE !,$CHAR(7),"WARNING: Multiple PRINCIPLE DXs entered for this Hospitalization!",!
DO XIT
QUIT
+9 DO GETACC
+10 SET X2=AUPNDOB
SET X1=APCDDATE
DO ^%DTC
SET AUPNDAYS=X
+11 DO ^APCDVCH2
+12 DO CHECKPVS
+13 DO ^APCDVCH1
+14 KILL APCDAGEE
+15 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",APCDVSIT,X))
IF X'=+X
QUIT
SET APCDICDP=$PIECE(^AUPNVPOV(X,0),U)
SET APCDICD=$$CODEC^ICDEX(80,APCDICDP)
Begin DoDot:1
+16 KILL APCDAGEE
+17 IF $$CHKE1^AUPNSICD(APCDICDP)
WRITE !,"External Cause code used for POV"
QUIT
+18 IF APCDICD=.9999!(APCDICD="ZZZ.999")
WRITE !,APCDICD_" Diagnosis used"
QUIT
+19 SET %=$$ICDDX^ICDEX(APCDICDP,$$VD^APCLV(APCDVSIT))
IF $PIECE(%,U,11)]""
IF AUPNSEX'=$PIECE(%,U,11)
WRITE !,"Gender of Patient invalid for this ICD code "_APCDICD
QUIT
+20 ;CSV
SET (A,B)=""
+21 ;CSV
IF $$VERSION^XPDUTL("BCSV")]""
Begin DoDot:2
+22 SET A=$PIECE(%,U,15)
SET B=$PIECE(%,U,16)
End DoDot:2
IF 1
+23 IF '$TEST
SET A=$PIECE($GET(^ICD9(APCDICDP,9999999)),U)
SET B=$PIECE($GET(^ICD9(APCDICDP,9999999)),U,2)
+24 IF A
IF A>$$AGE^AUPNPAT($PIECE($GET(^AUPNVSIT(APCDVSIT,0)),U,5),$$VD^APCLV(APCDVSIT))
SET APCDAGEE=""
+25 IF B
IF B<$$AGE^AUPNPAT($PIECE($GET(^AUPNVSIT(APCDVSIT,0)),U,5),$$VD^APCLV(APCDVSIT))
SET APCDAGEE=""
+26 IF $PIECE(APCDVREC,U,7)="H"
IF '$DATA(^APCDINPT(9,11,"AC",APCDICD))
IF $DATA(APCDAGEE)
WRITE !,"WARNING: ICD code invalid for age, please review "_APCDICD
QUIT
+27 IF $DATA(APCDAGEE)
WRITE !,"Age invalid for this ICD code. PLEASE REVIEW: "_APCDICD
QUIT
End DoDot:1
XIT ;
+1 KILL APCDTS,APCDVINR,APCDDS,APCDIACC,APCD1,APCD2,APCD3,APCDPREC,APCDSC,APCDICD9,APCDVCPV,APCDACC,APCDDUPE,APCDDXP,APCDACCO,APCDDUPO,APCDOPP,APCDDX,APCDPX,APCDFOUN,APCDOPP,APCDOPC,APCDDXP,APCDDXC,APCDDXOP,APCDOPDX,APCDVCPS
+2 KILL APCDE,APCDVCPV,APCDVPRC,APCDOP,APCDADM,APCDDIS,APCD3,APCDAGEE,A,B,%
+3 QUIT
GETTS ;
+1 SET APCDVINR=$ORDER(^AUPNVINP("AD",APCDVSIT,""))
SET APCDVINR=^AUPNVINP(APCDVINR,0)
SET APCDTS=$PIECE(APCDVINR,U,4)
SET APCDDS=$PIECE(APCDVINR,U,5)
+2 IF APCDTS=""
WRITE !,$CHAR(7),"WARNING: Admitting Service Missing",!
QUIT
+3 IF APCDDS=""
WRITE !,$CHAR(7),"WARNING: Discharge Service Missing",!
QUIT
+4 SET APCDTS=$PIECE(^DIC(45.7,APCDTS,9999999),U)
SET APCDDS=$PIECE(^DIC(45.7,APCDDS,9999999),U)
+5 IF APCDTS=""
WRITE !,$CHAR(7),"WARNING: Admitting Service Code Missing",!
+6 IF APCDDS=""
WRITE !,$CHAR(7),"WARNING: Discharge Service Code Missing",!
+7 QUIT
GETACC ;
+1 ;ACCEPT COMMAND NO LONGER NECESSARY FOR EXPORT
SET APCDACC=""
+2 QUIT
GETPOVS ;
+1 SET (APCD1,APCD2,APCD3)=0
FOR
SET APCD2=$ORDER(^AUPNVPOV("AD",APCDVSIT,APCD2))
IF APCD2=""
QUIT
SET APCD1=APCD1+1
DO SETPOV
+2 QUIT
SETPOV ;
+1 SET APCDPREC=^AUPNVPOV(APCD2,0)
SET APCDSC=$PIECE(APCDPREC,U,12)
IF APCDSC=""
SET APCDSC="S"
+2 IF APCDSC="P"
SET APCD3=APCD3+1
SET APCDVCPV("P")=$$CODEC^ICDEX(80,$PIECE(APCDPREC,U))_"^"_$PIECE(APCDPREC,U)_"^"_APCD2
QUIT
+3 SET APCDVCPV(APCDSC,APCD1)=$$CODEC^ICDEX(80,$PIECE(APCDPREC,U))_"^"_$PIECE(APCDPREC,U)_"^"_APCD2
+4 QUIT
CHECKPVS ;
C2 ;CERTAIN "V" CODES CANNOT BE PRIM DXS
+1 IF $DATA(^APCDINPT(2,11,"AC",$PIECE(APCDVCPV("P"),U)))
WRITE !,$CHAR(7),"WARNING: Diagnosis Code ",$PIECE(APCDVCPV("P"),U)," cannot be used as a PRIMARY DX! Please review.",!
C1 ;IF PRIM DX IS A "V" CODE SEC MUST BE "V" CODE ALSO
+1 ;WITH EXCEPTIONS
+2 ;I $E($P(APCDVCPV("P"),U))="V",'$D(^APCDINPT(1,11,"AC",$P(APCDVCPV("P"),U))) D C11
E1 ;CERTAIN CODES REQUIRE AN ACCEPT COMMAND
+1 IF $DATA(^APCDINPT(8,11,"AC",$PIECE(APCDVCPV("P"),U)))
IF '$DATA(APCDACC)
SET APCDICD9=$PIECE(APCDVCPV("P"),U)
DO E1W
+2 SET APCD1=0
FOR
SET APCD1=$ORDER(APCDVCPV("S",APCD1))
IF APCD1'=+APCD1
QUIT
DO E11
+3 ;
E2 ;IF CODE V30-V39 (.0) ADM SRV MUST BE NEWBORN
+1 IF $DATA(^APCDINPT(4,"AC",$PIECE(APCDVCPV("P"),U)))
IF APCDTS'="07"
WRITE !,$CHAR(7),"WARNING: Primary DX is ",$PIECE(APCDVCPV("P"),U)," therefore Admitting Service must",!,"be NEWBORN (07)!",!
QUIT
E3 ;IF PRIM DX IS V30-V39(.1) ADM SRV MUST BE ,11
+1 ;I $D(^APCDINPT(3,11,"AC",$P(APCDVCPV("P"),U))),APCDTS'=11 W !,$C(7),"WARNING: Primary DX is ",$P(APCDVCPV("P"),U)," therefore Admitting Service must",!,"be PEDIATRICS (11)!",! Q
E4 ;IF PRIM DX (V30-V39 (.0 OR ,.1)) AGE CANNOT BE > 3 DAYS
+1 IF (($DATA(^APCDINPT(4,11,"AC",$PIECE(APCDVCPV("P"),U))))!($DATA(^APCDINPT(3,11,"AC",$PIECE(APCDVCPV("P"),U)))))
IF AUPNDAYS>3
WRITE !,$CHAR(7),"WARNING: Primary DX is ",$PIECE(APCDVCPV("P"),U)," therefore Age of Patient cannot be",!,"greater than 3 days!",!
QUIT
+2 QUIT
E11 ;
+1 IF $DATA(^APCDINPT(8,11,"AC",$PIECE(APCDVCPV("S",APCD1),U)))
IF '$DATA(APCDACC)
SET APCDICD9=$PIECE(APCDVCPV("S",APCD1),U)
DO E1W
+2 QUIT
E1W ;
+1 WRITE !,$CHAR(7),"WARNING: You have used ICD code ",APCDICD9,", please review with Your Supervisor.",!
QUIT
+2 QUIT
C11 ;
+1 ;S APCD1=0 F S APCD1=$O(APCDVCPV("S",APCD1)) Q:APCD1'=+APCD1 D C12
+2 QUIT
C12 ;
+1 ;I $E($P(APCDVCPV("S",APCD1),U))'="V" W !,$C(7),"WARNING: The primary POV for this Hospitalization is a V Code, therefore",!,"the Secondary POVs must be V codes. Please correct this Visit.",!
+2 QUIT
