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