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

APCDVCH.m

Go to the documentation of this file. 
  1. 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
  1. CHKHOSP ;
  1.  Q:'$O(^AUPNVINP("AD",APCDVSIT,""))
  1.  W !
  1.  D GETTS
  1.  Q:APCDTS=""
  1.  Q:APCDDS=""
  1.  D GETPOVS
  1.  I '$D(APCDVCPV("P")) W !,$C(7),"WARNING: No PRINCIPLE DX entered for this Hospitalization!",! D XIT Q
  1.  I APCD3>1 W !,$C(7),"WARNING: Multiple PRINCIPLE DXs entered for this Hospitalization!",! D XIT Q
  1.  D GETACC
  1.  S X2=AUPNDOB,X1=APCDDATE D ^%DTC S AUPNDAYS=X
  1.  D ^APCDVCH2
  1.  D CHECKPVS
  1.  D ^APCDVCH1
  1.  K APCDAGEE
  1.  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
  1.  .K APCDAGEE
  1.  .I $$CHKE1^AUPNSICD(APCDICDP) W !,"External Cause code used for POV" Q
  1.  .I APCDICD=.9999!(APCDICD="ZZZ.999") W !,APCDICD_" Diagnosis used" Q
  1.  .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
  1.  .S (A,B)=""  ;CSV
  1.  .I $$VERSION^XPDUTL("BCSV")]"" D  I 1  ;CSV
  1.  ..S A=$P(%,U,15),B=$P(%,U,16)
  1.  .E  S A=$P($G(^ICD9(APCDICDP,9999999)),U),B=$P($G(^ICD9(APCDICDP,9999999)),U,2)
  1.  .I A,A>$$AGE^AUPNPAT($P($G(^AUPNVSIT(APCDVSIT,0)),U,5),$$VD^APCLV(APCDVSIT)) S APCDAGEE=""
  1.  .I B,B<$$AGE^AUPNPAT($P($G(^AUPNVSIT(APCDVSIT,0)),U,5),$$VD^APCLV(APCDVSIT)) S APCDAGEE=""
  1.  .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
  1.  .I $D(APCDAGEE) W !,"Age invalid for this ICD code.  PLEASE REVIEW: "_APCDICD Q
  1. XIT ;
  1.  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
  1.  K APCDE,APCDVCPV,APCDVPRC,APCDOP,APCDADM,APCDDIS,APCD3,APCDAGEE,A,B,%
  1.  Q
  1. GETTS ;
  1.  S APCDVINR=$O(^AUPNVINP("AD",APCDVSIT,"")),APCDVINR=^AUPNVINP(APCDVINR,0),APCDTS=$P(APCDVINR,U,4),APCDDS=$P(APCDVINR,U,5)
  1.  I APCDTS="" W !,$C(7),"WARNING: Admitting Service Missing",! Q
  1.  I APCDDS="" W !,$C(7),"WARNING: Discharge Service Missing",! Q
  1.  S APCDTS=$P(^DIC(45.7,APCDTS,9999999),U),APCDDS=$P(^DIC(45.7,APCDDS,9999999),U)
  1.  I APCDTS="" W !,$C(7),"WARNING: Admitting Service Code Missing",!
  1.  I APCDDS="" W !,$C(7),"WARNING: Discharge Service Code Missing",!
  1.  Q
  1. GETACC ;
  1.  S APCDACC=""  ;ACCEPT COMMAND NO LONGER NECESSARY FOR EXPORT
  1.  Q
  1. GETPOVS ;
  1.  S (APCD1,APCD2,APCD3)=0 F  S APCD2=$O(^AUPNVPOV("AD",APCDVSIT,APCD2)) Q:APCD2=""  S APCD1=APCD1+1 D SETPOV
  1.  Q
  1. SETPOV ;
  1.  S APCDPREC=^AUPNVPOV(APCD2,0),APCDSC=$P(APCDPREC,U,12) S:APCDSC="" APCDSC="S"
  1.  I APCDSC="P" S APCD3=APCD3+1,APCDVCPV("P")=$$CODEC^ICDEX(80,$P(APCDPREC,U))_"^"_$P(APCDPREC,U)_"^"_APCD2 Q
  1.  S APCDVCPV(APCDSC,APCD1)=$$CODEC^ICDEX(80,$P(APCDPREC,U))_"^"_$P(APCDPREC,U)_"^"_APCD2
  1.  Q
  1. CHECKPVS ;
  1. C2 ;CERTAIN "V" CODES CANNOT BE PRIM DXS
  1.  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.",!
  1. C1 ;IF PRIM DX IS A "V" CODE SEC MUST BE "V" CODE ALSO
  1.  ;WITH EXCEPTIONS
  1.  ;I $E($P(APCDVCPV("P"),U))="V",'$D(^APCDINPT(1,11,"AC",$P(APCDVCPV("P"),U))) D C11
  1. E1 ;CERTAIN CODES REQUIRE AN ACCEPT COMMAND
  1.  I $D(^APCDINPT(8,11,"AC",$P(APCDVCPV("P"),U))),'$D(APCDACC) S APCDICD9=$P(APCDVCPV("P"),U) D E1W
  1.  S APCD1=0 F  S APCD1=$O(APCDVCPV("S",APCD1)) Q:APCD1'=+APCD1  D E11
  1.  ;
  1. E2 ;IF CODE V30-V39 (.0) ADM SRV MUST BE NEWBORN
  1.  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
  1. 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
  1. E4 ;IF PRIM DX (V30-V39 (.0 OR ,.1)) AGE CANNOT BE > 3 DAYS
  1.  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
  1.  Q
  1. E11 ;
  1.  I $D(^APCDINPT(8,11,"AC",$P(APCDVCPV("S",APCD1),U))),'$D(APCDACC) S APCDICD9=$P(APCDVCPV("S",APCD1),U) D E1W
  1.  Q
  1. E1W ;
  1.  W !,$C(7),"WARNING: You have used ICD code ",APCDICD9,", please review with Your Supervisor.",! Q
  1.  Q
  1. C11 ;
  1.  ;S APCD1=0 F  S APCD1=$O(APCDVCPV("S",APCD1)) Q:APCD1'=+APCD1  D C12
  1.  Q
  1. 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.",!
  1.  Q