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

APCDBPOV.m

Go to the documentation of this file. 
  1. APCDBPOV ; IHS/CMI/LAB - POV LOOKUP ; 06 Oct 2015  1:21 PM
  1.  ;;2.0;IHS PCC SUITE;**11,13**;MAY 14, 2009;Build 9
  1.  ;
  1. START ;
  1.  D EN^XBNEW("LEX^APCDBPOV","APCDDATE;APCDTCLK;APCDVSIT;APCDTDIA,APCDT90")
  1.  Q
  1. LEX ;EP - called from input template
  1.  I APCDT90=1 G XITL
  1.  S APCDIMP=APCDT90
  1.  K DIR
  1.  K ^TMP("LEXSCH",$J)
  1.  I APCDIMP=1 D CONFIG^LEXSET("ICD","ICD",$P(APCDDATE,"."))
  1.  I APCDIMP=30 D CONFIG^LEXSET("10D","10D",$P(APCDDATE,"."))
  1.  S DIR(0)="FO^1:60",DIR("A")="  RETAINED FOREIGN BODY (Z18-Z18.9)"
  1.  S DIR("?")="^D HELPRFB^AUPNSICH"
  1.  S DIR("??")="^D HELPRFB^AUPNSICH"
  1.  KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) S APCDTSKI=1,APCDTCLK="" G XITL
  1.  I Y="" S APCDTSKI=1,APCDTCLK="" G XITL
  1.  S APCDUINP=Y
  1.  K ^TMP("LEXSCH",$J),LEX,^TMP("LEXHIT",$J),^TMP("LEXFND",$J)
  1.  I APCDIMP=1 D CONFIG^LEXSET("ICD","ICD",$P(APCDDATE,"."))
  1.  I APCDIMP=30 D CONFIG^LEXSET("10D","10D",$P(APCDDATE,"."))
  1.  S X=APCDUINP
  1.  ;I APCDIMP=1 S DIC("S")="I $$ICDONE9^APCDBPOV(+Y,LEXVDT)"
  1.  I APCDIMP=30 S DIC("S")="I $$ICDONE1^APCDBPOV(+Y,LEXVDT)"
  1.  ;S DIC("A")=$S($G(APCDTDIA)]"":APCDTDIA_": ",1:"Enter Cause of Morbidity: ")
  1.  I APCDIMP=1 D LOOK^LEXA(X,"ICD",999,"ICD",$P(APCDDATE,".",1))
  1.  I APCDIMP=30 D LOOK^LEXA(X,"10D",999,"10D",$P(APCDDATE,"."))
  1.  I 'LEX D  G LEX
  1.  .S X=0 F  S X=$O(LEX("HLP",X)) Q:X'=+X  W !,LEX("HLP",X)
  1.  ;display all codes and call reader
  1.  S APCDANS=""
  1.  D GETANS^APCDAPOV
  1.  I APCDY="^" W ! G LEX
  1.  I APCDY="" W ! G LEX
  1.  I '$G(APCDY) W ! G LEX
  1.  I APCDIMP=1 S Y=$$ICDONE^LEXU($P(^TMP("LEXHIT",$J,APCDY),U,1),$P(APCDDATE,"."))
  1.  I APCDIMP=30 S Y=$$ONE^LEXU($P(^TMP("LEXHIT",$J,APCDY),U,1),$P(APCDDATE,"."),"10D")
  1.  K DO,^TMP("LEXSCH",$J)
  1.  I $G(Y)="" W !!,"lexicon isn't passing back an ICD code." S APCDTERR=1,APCDTCLK="" G XITL
  1.  S %=$$ICDDX^ICDEX(Y,$P(APCDDATE,"."),APCDIMP,"E")
  1.  I $P(%,U,1)="-1" W !!,"lexicon isn't passing back an ICD code." S APCDTERR=1,APCDTCLK="" G XITL
  1. LEXN ;
  1.  S APCDTCLK="`"_+%,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:'$$CHKRFB^AUPNSICD($P(ALEXICD,U,1)) ""
  1.  Q 1
  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
  1.  ;S ALEXVDT=$S(+$G(ALEXVDT)>0:ALEXVDT,1:$$DT^XLFDT)
  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:'$$CHKRFB^AUPNSICD($P(ALEXICD,U,1)) ""
  1.  Q 1
  1. EDITRFB1 ;
  1.  S APCDTDIA="  RETAINED FOREIGN BODY (Z18-Z18.9)"
  1.  S APCDTPCC="",APCDINPE=1
  1.  K DIR
  1.  S APCDTPCC="",APCDINPE=1,APCDTNPV="",APCDTNOG=""
  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="" S APCDD=DT
  1.  NEW APCDIMP,APCDANS
  1. RI ;
  1.  S APCDIMP=$$IMP^AUPNSICD(APCDD)
  1.  Q:APCDIMP'=30
  1. RLEX ;EP - called from input template
  1.  ;reader call to get TEXT for code
  1.  K DIR,APCDTDEL,APCDTUPH
  1.  K ^TMP("LEXSCH",$J)
  1.  D CONFIG^LEXSET("10D","10D",$P(APCDD,"."))
  1.  S DIR(0)="FO^1:60",DIR("A")=APCDTDIA
  1.  S DIR("?")="^D HELPRFB^AUPNSICH"
  1.  S DIR("??")="^D HELPRFB^AUPNSICH"
  1.  I $$VAL^XBDIQ1(9000010.07,APCDTDA,APCDTFIE)]"" S DIR("B")=$$VAL^XBDIQ1(9000010.07,APCDTDA,APCDTFIE)
  1.  KILL DA D ^DIR KILL DIR
  1.  I X="@",$G(APCDIAIE) S APCDTDEL=1 G XITR
  1.  I X=U S APCDTUPH=1 G XITR
  1.  I $D(DIRUT) S APCDTSKI=1 G XITR
  1.  I Y="" G XITR
  1.  S APCDUINP=Y
  1.  I APCDUINP=$$VAL^XBDIQ1(9000010.07,APCDTDA,APCDTFIE) G XITR
  1.  S %=""
  1.  I APCDUINP=".9999" S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999"),,APCDIMP,"E") G LEXR
  1.  I APCDIMP=30,APCDUINP="ZZZ.999" S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999")) G LEXR
  1.  I APCDIMP=30,$E(APCDUINP,1,4)="ZZZ." S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999")) G LEXR
  1.  I $E(APCDUINP,1,7)="UNCODED" S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999")) G LEXR
  1.  I APCDUINP["UNCODED D" S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999")) G LEXR
  1.  K ^TMP("LEXSCH",$J),^TMP("LEXHIT",$J),LEX,^TMP("LEXFND",$J)
  1.  I APCDIMP=30 D CONFIG^LEXSET("10D","10D",$P(APCDD,"."))
  1.  S X=APCDUINP
  1.  I APCDIMP=30 S DIC("S")="I $$ICDONE1^APCDBPOV(+Y,LEXVDT)"
  1.  I $G(APCDTDIA)]"" S DIC("A")=$G(APCDTDIA)
  1.  I APCDIMP=30 D LOOK^LEXA(X,"10D",999,"10D",$P(APCDD,"."))
  1.  I 'LEX D  G RLEX
  1.  .S X=0 F  S X=$O(LEX("HLP",X)) Q:X'=+X  W !,LEX("HLP",X)
  1.  ;display all codes and call reader
  1.  S APCDANS=""
  1.  D GETANS^APCDAPOV
  1.  I APCDY="^" W ! G RLEX
  1.  I APCDY="" W ! G RLEX
  1.  I '$G(APCDY) W ! G RLEX
  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,APCDTNPV="" G XITR
  1.  S %=$$ICDDX^ICDEX(Y,$P(APCDD,"."),30,"E")
  1.  I $P(%,U,1)="-1" W !!,"lexicon isn't passing back an ICD code." S APCDTERR=1,APCDTNPV="" G XITR
  1. LEXR ;
  1.  S APCDTNPV="`"_+%
  1.  W !
  1. XITR K Y,X,DO,D,DD,DIPGM,APCDTPCC
  1.  Q