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

APCDXPOV.m

Go to the documentation of this file. 
  1. APCDXPOV ; IHS/CMI/LAB - POV LOOKUP ;
  1.  ;;2.0;IHS PCC SUITE;**11,20**;MAY 14, 2009;Build 25
  1.  ;
  1. START ;
  1.  S (APCDLOOK,APCDTNQP)=""
  1.  D EN^XBNEW("START1^APCDXPOV","APCDTSKI;APCDTDA;APCDLOOK;APCDDATE;APCDTERR;APCDPAT;DFN;APCDTNQP;APCDTPCC;APCDTDIA;APCDVSIT;APCDINAD;BDGV")
  1.  Q
  1. START1 ;EP
  1.  S APCDTPCC="",APCDINPE=1,APCDD=""
  1.  ;FOR NOW IF ICD9 CALL LEX, AFTER VA SENDS OUT ICD10 LEX JUST D LEX Q
  1.  NEW %,D
  1.  S D=""
  1.  I $G(APCDVSIT),$D(^AUPNVSIT(APCDVSIT)) D
  1.  .;I $P(^AUPNVSIT(APCDVSIT,0),U,7)="H",$$DSCHDATE^APCLV(APCDVSIT)]"" S APCDD=$$DSCHDATE^APCLV(APCDVSIT) Q
  1.  .S APCDD=$P($P(^AUPNVSIT(APCDVSIT,0),U),".")
  1.  I APCDD="" S APCDD=$P($G(APCDDATE),".")
  1.  I APCDD="",$G(BDGV),$D(^AUPNVSIT(BDGV,0)) D
  1.  .S APCDD=$P($P(^AUPNVSIT(BDGV,0),U),".")
  1.  I APCDD="" S APCDD=DT
  1. I S APCDIMP=$$IMP^AUPNSICD(APCDD)
  1.  ;
  1. LEX ;EP - called from input template
  1.  ;reader call to get TEXT for code
  1.  K DIR
  1.  K ^TMP("LEXSCH",$J)
  1.  I APCDIMP=1 D CONFIG^LEXSET("ICD","ICD",$P(APCDD,"."))
  1.  I APCDIMP=30 D CONFIG^LEXSET("10D","10D",$P(APCDD,"."))
  1.  S DIR(0)="FO^1:60",DIR("A")=$S($G(APCDTDIA)]"":APCDTDIA,1:"Enter PURPOSE OF VISIT")
  1.  S DIR("?")="^D HELPADX^AUPNSICA"
  1.  S DIR("??")="^D HELPADX^AUPNSICA"
  1.  KILL DA
  1.  I $G(APCDTDA),$$VAL^XBDIQ1(9000010.02,APCDTDA,.12)]"" S DIR("B")=$$VAL^XBDIQ1(9000010.02,APCDTDA,.12)
  1.  D ^DIR KILL DIR
  1.  I $D(DIRUT) S APCDTSKI=1,APCDLOOK="" G XITL
  1.  I Y="" S APCDTSKI=1,APCDLOOK="" G XITL
  1.  S APCDUINP=Y
  1.  I APCDUINP=$$VAL^XBDIQ1(9000010.02,APCDTDA,.12) G XITL
  1.  I APCDIMP=1 D CONFIG^LEXSET("ICD","ICD",$P(APCDD,"."))
  1.  I APCDIMP=30 D CONFIG^LEXSET("10D","10D",$P(APCDD,"."))
  1.  S X=APCDUINP
  1.  S %=""
  1.  I X="@" W !!,"Admitting Diagnosis is Required." G LEX
  1.  I APCDUINP=".9999" S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999")) G LEXN
  1.  I APCDIMP=30,APCDUINP="ZZZ.999" S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999")) G LEXN
  1.  I APCDIMP=30,$E(APCDUINP,1,4)="ZZZ." S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999")) G LEXN
  1.  I $E(APCDUINP,1,7)="UNCODED" S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999")) G LEXN
  1.  I APCDUINP["UNCODED D" S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999")) G LEXN
  1.  I APCDIMP=1 S DIC("S")="I $$ICDONE9^APCDXPOV(+Y,LEXVDT)"
  1.  I APCDIMP=30 S DIC("S")="I $$ICDONE1^APCDXPOV(+Y,LEXVDT)"
  1.  S DIC("A")=$S($G(APCDTDIA)]"":APCDTDIA_": ",1:"Enter Admitting Diagnosis: ")
  1.  I APCDIMP=1 D LOOK^LEXA(X,"ICD",999,"ICD",$P(APCDD,"."))
  1.  I APCDIMP=30 D LOOK^LEXA(X,"10D",999,"10D",$P(APCDD,"."))
  1.  I 'LEX D  G:%="" LEX G:% LEXN
  1.  .S X=0 F  S X=$O(LEX("HLP",X)) Q:X'=+X  W !,LEX("HLP",X)
  1.  .;now check fileman V2.0 PATCH 20 CR#554
  1.  .W !!,"now trying secondary fileman lookup..."
  1.  .S %="" S X=APCDUINP,DIC="^ICD9(",DIC(0)="MEQ",DIC("S")="D ^AUPNSICD" D ^DIC K DIC
  1.  .S %="" I $P(Y,U)'=-1 S %=+Y
  1.  ;display all codes and call reader
  1.  S APCDANS=""
  1.  D GETANS^APCDAPOV
  1.  I APCDY="^" W ! D  G:%="" LEX G:% LEXN
  1.  .;now check fileman
  1.  .;W !!,"now trying fileman lookup..."
  1.  .S %="" ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="QME" D ^DIC K DIC
  1.  .;S %="" I $P(Y,U)'=-1 S %=+Y
  1.  I APCDY="" W ! D  G:%="" LEX G:% LEXN
  1.  .;now check fileman
  1.  .;W !!,"now trying fileman lookup..."
  1.  .S %="" ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="MEQ" D ^DIC K DIC
  1.  .;S %="" I $P(Y,U)'=-1 S %=+Y
  1.  I '$G(APCDY) W ! D  G:%="" LEX G:% LEXN
  1.  .;now check fileman
  1.  .;W !!,"now trying fileman lookup..."
  1.  .S %="" ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="MEQ" D ^DIC K DIC
  1.  .;S %="" I $P(Y,U)'=-1 S %=+Y
  1.  I APCDIMP=1 S Y=$$ICDONE^LEXU($P(^TMP("LEXHIT",$J,APCDY),U,1),$P(APCDD,"."))
  1.  I APCDIMP=30 S Y=$$ONE^LEXU($P(^TMP("LEXHIT",$J,APCDY),U,1),$P(APCDD,"."),"10D")
  1.  K DO,^TMP("LEXSCH",$J)
  1.  I $G(Y)="" W !!,"lexicon isn't passing back an ICD code." S APCDTERR=1,APCDLOOK="" G XITL
  1.  S %=$$ICDDX^ICDEX(Y,$P(APCDD,"."),APCDIMP,"E")
  1.  I $P(%,U,1)="-1" W !!,"lexicon isn't passing back an ICD code." S APCDTERR=1,APCDLOOK="" G XITL
  1. LEXN ;
  1.  S APCDLOOK="`"_+%,APCDTNQP=APCDUINP
  1.  W !
  1. XITL K Y,X,DO,D,DD,DIPGM,APCDTPCC
  1.  Q
  1. ICDONE9(ALEX,ALEXVDT) ;EP - Return one ICD code for an expression
  1.  ;    LEX      IEN of file 757.01
  1.  ;    LEXVDT   Date to use for screening by codes
  1.  N ALEXICD
  1.  S ALEXVDT=$S(+$G(ALEXVDT)>0:ALEXVDT,1:$$DT^XLFDT)
  1.  S ALEX=$$ICDONE^LEXU(ALEX,ALEXVDT) Q:ALEX="" ""
  1.  S ALEXICD=$$ICDDX^ICDEX(ALEX,ALEXVDT,1,"E")
  1.  Q:$P(ALEXICD,"^",2)="INVALID CODE" ""
  1.  Q:'$$CHK^AUPNSICA($P(ALEXICD,U,1)) ""
  1.  Q 1
  1. ICDONE1(ALEX,ALEXVDT) ;EP - Return one ICD code for an expression
  1.  ;    LEX      IEN of file 757.01
  1.  ;    LEXVDT   Date to use for screening by codes
  1.  N ALEXICD,ALEVXDT,%
  1.  S ALEX=$$ONE^LEXU(ALEX,ALEXVDT,"10D") Q:ALEX="" ""
  1.  S ALEXICD=$$ICDDX^ICDEX(ALEX,ALEXVDT,30,"E")
  1.  Q:$P(ALEXICD,"^",2)="INVALID CODE" ""
  1.  Q:'$$CHK^AUPNSICA($P(ALEXICD,U,1)) ""
  1.  Q 1
  1. EDIT01 ;EP
  1.  D EN^XBNEW("EDIT011^APCDXPOV","APCDTDA;APCDVSIT;APCDPAT;APCDDATE;DFN;AUPNPAT;AUPNVSIT;APCDTTMP;BDGV")
  1.  Q
  1. EDIT011 ;
  1.  K DIE,DA,DR
  1.  ;
  1. 1 ;EDIT .12 OF V HOSP
  1.  W !
  1.  K DIR
  1.  S APCDD=""
  1.  I $G(APCDVSIT),$D(^AUPNVSIT(APCDVSIT)) D
  1.  .;I $P(^AUPNVSIT(APCDVSIT,0),U,7)="H",$$DSCHDATE^APCLV(APCDVSIT)]"" S APCDD=$$DSCHDATE^APCLV(APCDVSIT) Q
  1.  .S APCDD=$P($P(^AUPNVSIT(APCDVSIT,0),U),".")
  1.  I APCDD="" S APCDD=$P($G(APCDDATE),".")
  1.  I APCDD="",$G(BDGV),$D(^AUPNVSIT(BDGV,0)) D
  1.  .S APCDD=$P($P(^AUPNVSIT(BDGV,0),U),".")
  1.  I APCDD="" S APCDD=DT
  1.  S APCDHDAT=APCDD
  1.  ;12
  1.  W !!,"Please Note:  Admitting Diagnosis is Required.",!
  1.  S APCDIMP=$$IMP^AUPNSICD(APCDD)
  1.  S APCDTFIE=".12",APCDTDIA="ADMITTING DX",APCDTDEL="",APCDLOOK="" K APCDINAD
  1.  D LEX
  1.  I $G(APCDTSKI) Q  ;"^" OUT
  1.  I APCDLOOK]"" S DA=APCDTDA,DIE="^AUPNVINP(",DR=".12///"_APCDLOOK D ^DIE K DA,DIE,DR
  1.  I $$VAL^XBDIQ1(9000010.02,APCDTDA,.12)="" G 1
  1.  Q