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
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
+2 ;
START ;
+1 DO EN^XBNEW("LEX^APCDBPOV","APCDDATE;APCDTCLK;APCDVSIT;APCDTDIA,APCDT90")
+2 QUIT
LEX ;EP - called from input template
+1 IF APCDT90=1
GOTO XITL
+2 SET APCDIMP=APCDT90
+3 KILL DIR
+4 KILL ^TMP("LEXSCH",$JOB)
+5 IF APCDIMP=1
DO CONFIG^LEXSET("ICD","ICD",$PIECE(APCDDATE,"."))
+6 IF APCDIMP=30
DO CONFIG^LEXSET("10D","10D",$PIECE(APCDDATE,"."))
+7 SET DIR(0)="FO^1:60"
SET DIR("A")=" RETAINED FOREIGN BODY (Z18-Z18.9)"
+8 SET DIR("?")="^D HELPRFB^AUPNSICH"
+9 SET DIR("??")="^D HELPRFB^AUPNSICH"
+10 KILL DA
DO ^DIR
KILL DIR
+11 IF $DATA(DIRUT)
SET APCDTSKI=1
SET APCDTCLK=""
GOTO XITL
+12 IF Y=""
SET APCDTSKI=1
SET APCDTCLK=""
GOTO XITL
+13 SET APCDUINP=Y
+14 KILL ^TMP("LEXSCH",$JOB),LEX,^TMP("LEXHIT",$JOB),^TMP("LEXFND",$JOB)
+15 IF APCDIMP=1
DO CONFIG^LEXSET("ICD","ICD",$PIECE(APCDDATE,"."))
+16 IF APCDIMP=30
DO CONFIG^LEXSET("10D","10D",$PIECE(APCDDATE,"."))
+17 SET X=APCDUINP
+18 ;I APCDIMP=1 S DIC("S")="I $$ICDONE9^APCDBPOV(+Y,LEXVDT)"
+19 IF APCDIMP=30
SET DIC("S")="I $$ICDONE1^APCDBPOV(+Y,LEXVDT)"
+20 ;S DIC("A")=$S($G(APCDTDIA)]"":APCDTDIA_": ",1:"Enter Cause of Morbidity: ")
+21 IF APCDIMP=1
DO LOOK^LEXA(X,"ICD",999,"ICD",$PIECE(APCDDATE,".",1))
+22 IF APCDIMP=30
DO LOOK^LEXA(X,"10D",999,"10D",$PIECE(APCDDATE,"."))
+23 IF 'LEX
Begin DoDot:1
+24 SET X=0
FOR
SET X=$ORDER(LEX("HLP",X))
IF X'=+X
QUIT
WRITE !,LEX("HLP",X)
End DoDot:1
GOTO LEX
+25 ;display all codes and call reader
+26 SET APCDANS=""
+27 DO GETANS^APCDAPOV
+28 IF APCDY="^"
WRITE !
GOTO LEX
+29 IF APCDY=""
WRITE !
GOTO LEX
+30 IF '$GET(APCDY)
WRITE !
GOTO LEX
+31 IF APCDIMP=1
SET Y=$$ICDONE^LEXU($PIECE(^TMP("LEXHIT",$JOB,APCDY),U,1),$PIECE(APCDDATE,"."))
+32 IF APCDIMP=30
SET Y=$$ONE^LEXU($PIECE(^TMP("LEXHIT",$JOB,APCDY),U,1),$PIECE(APCDDATE,"."),"10D")
+33 KILL DO,^TMP("LEXSCH",$JOB)
+34 IF $GET(Y)=""
WRITE !!,"lexicon isn't passing back an ICD code."
SET APCDTERR=1
SET APCDTCLK=""
GOTO XITL
+35 SET %=$$ICDDX^ICDEX(Y,$PIECE(APCDDATE,"."),APCDIMP,"E")
+36 IF $PIECE(%,U,1)="-1"
WRITE !!,"lexicon isn't passing back an ICD code."
SET APCDTERR=1
SET APCDTCLK=""
GOTO XITL
LEXN ;
+1 SET APCDTCLK="`"_+%
SET APCDTNQP=APCDUINP
+2 WRITE !
XITL KILL Y,X,DO,D,DD,DIPGM,APCDTPCC
+1 QUIT
ICDONE9(ALEX,ALEXVDT) ;EP - Return one ICD code for an expression
+1 ; LEX IEN of file 757.01
+2 ; LEXVDT Date to use for screening by codes
+3 NEW ALEXICD
+4 SET ALEXVDT=$SELECT(+$GET(ALEXVDT)>0:ALEXVDT,1:$$DT^XLFDT)
+5 SET ALEX=$$ICDONE^LEXU(ALEX,ALEXVDT)
IF ALEX=""
QUIT ""
+6 SET ALEXICD=$$ICDDX^ICDEX(ALEX,ALEXVDT,1,"E")
+7 IF $PIECE(ALEXICD,"^",2)="INVALID CODE"
QUIT ""
+8 IF '$$CHKRFB^AUPNSICD($PIECE(ALEXICD,U,1))
QUIT ""
+9 QUIT 1
+10 ;
ICDONE1(ALEX,ALEXVDT) ;EP - Return one ICD code for an expression
+1 ; LEX IEN of file 757.01
+2 ; LEXVDT Date to use for screening by codes
+3 NEW ALEXICD
+4 ;S ALEXVDT=$S(+$G(ALEXVDT)>0:ALEXVDT,1:$$DT^XLFDT)
+5 SET ALEX=$$ONE^LEXU(ALEX,ALEXVDT,"10D")
IF ALEX=""
QUIT ""
+6 SET ALEXICD=$$ICDDX^ICDEX(ALEX,ALEXVDT,30,"E")
+7 IF $PIECE(ALEXICD,"^",2)="INVALID CODE"
QUIT ""
+8 IF '$$CHKRFB^AUPNSICD($PIECE(ALEXICD,U,1))
QUIT ""
+9 QUIT 1
EDITRFB1 ;
+1 SET APCDTDIA=" RETAINED FOREIGN BODY (Z18-Z18.9)"
+2 SET APCDTPCC=""
SET APCDINPE=1
+3 KILL DIR
+4 SET APCDTPCC=""
SET APCDINPE=1
SET APCDTNPV=""
SET APCDTNOG=""
+5 SET APCDD=""
+6 IF $GET(APCDVSIT)
IF $DATA(^AUPNVSIT(APCDVSIT))
Begin DoDot:1
+7 IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,7)="H"
IF $$DSCHDATE^APCLV(APCDVSIT)]""
SET APCDD=$$DSCHDATE^APCLV(APCDVSIT)
QUIT
+8 SET APCDD=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")
End DoDot:1
+9 IF APCDD=""
SET APCDD=$PIECE($GET(APCDDATE),".")
+10 IF APCDD=""
SET APCDD=DT
+11 NEW APCDIMP,APCDANS
RI ;
+1 SET APCDIMP=$$IMP^AUPNSICD(APCDD)
+2 IF APCDIMP'=30
QUIT
RLEX ;EP - called from input template
+1 ;reader call to get TEXT for code
+2 KILL DIR,APCDTDEL,APCDTUPH
+3 KILL ^TMP("LEXSCH",$JOB)
+4 DO CONFIG^LEXSET("10D","10D",$PIECE(APCDD,"."))
+5 SET DIR(0)="FO^1:60"
SET DIR("A")=APCDTDIA
+6 SET DIR("?")="^D HELPRFB^AUPNSICH"
+7 SET DIR("??")="^D HELPRFB^AUPNSICH"
+8 IF $$VAL^XBDIQ1(9000010.07,APCDTDA,APCDTFIE)]""
SET DIR("B")=$$VAL^XBDIQ1(9000010.07,APCDTDA,APCDTFIE)
+9 KILL DA
DO ^DIR
KILL DIR
+10 IF X="@"
IF $GET(APCDIAIE)
SET APCDTDEL=1
GOTO XITR
+11 IF X=U
SET APCDTUPH=1
GOTO XITR
+12 IF $DATA(DIRUT)
SET APCDTSKI=1
GOTO XITR
+13 IF Y=""
GOTO XITR
+14 SET APCDUINP=Y
+15 IF APCDUINP=$$VAL^XBDIQ1(9000010.07,APCDTDA,APCDTFIE)
GOTO XITR
+16 SET %=""
+17 IF APCDUINP=".9999"
SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"),,APCDIMP,"E")
GOTO LEXR
+18 IF APCDIMP=30
IF APCDUINP="ZZZ.999"
SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"))
GOTO LEXR
+19 IF APCDIMP=30
IF $EXTRACT(APCDUINP,1,4)="ZZZ."
SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"))
GOTO LEXR
+20 IF $EXTRACT(APCDUINP,1,7)="UNCODED"
SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"))
GOTO LEXR
+21 IF APCDUINP["UNCODED D"
SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"))
GOTO LEXR
+22 KILL ^TMP("LEXSCH",$JOB),^TMP("LEXHIT",$JOB),LEX,^TMP("LEXFND",$JOB)
+23 IF APCDIMP=30
DO CONFIG^LEXSET("10D","10D",$PIECE(APCDD,"."))
+24 SET X=APCDUINP
+25 IF APCDIMP=30
SET DIC("S")="I $$ICDONE1^APCDBPOV(+Y,LEXVDT)"
+26 IF $GET(APCDTDIA)]""
SET DIC("A")=$GET(APCDTDIA)
+27 IF APCDIMP=30
DO LOOK^LEXA(X,"10D",999,"10D",$PIECE(APCDD,"."))
+28 IF 'LEX
Begin DoDot:1
+29 SET X=0
FOR
SET X=$ORDER(LEX("HLP",X))
IF X'=+X
QUIT
WRITE !,LEX("HLP",X)
End DoDot:1
GOTO RLEX
+30 ;display all codes and call reader
+31 SET APCDANS=""
+32 DO GETANS^APCDAPOV
+33 IF APCDY="^"
WRITE !
GOTO RLEX
+34 IF APCDY=""
WRITE !
GOTO RLEX
+35 IF '$GET(APCDY)
WRITE !
GOTO RLEX
+36 IF APCDIMP=1
SET Y=$$ICDONE^LEXU($PIECE(^TMP("LEXHIT",$JOB,APCDY),U,1),$PIECE(APCDD,"."))
+37 IF APCDIMP=30
SET Y=$$ONE^LEXU($PIECE(^TMP("LEXHIT",$JOB,APCDY),U,1),$PIECE(APCDD,"."),"10D")
+38 KILL DO,^TMP("LEXSCH",$JOB)
+39 IF $GET(Y)=""
WRITE !!,"lexicon isn't passing back an ICD code."
SET APCDTERR=1
SET APCDTNPV=""
GOTO XITR
+40 SET %=$$ICDDX^ICDEX(Y,$PIECE(APCDD,"."),30,"E")
+41 IF $PIECE(%,U,1)="-1"
WRITE !!,"lexicon isn't passing back an ICD code."
SET APCDTERR=1
SET APCDTNPV=""
GOTO XITR
LEXR ;
+1 SET APCDTNPV="`"_+%
+2 WRITE !
XITR KILL Y,X,DO,D,DD,DIPGM,APCDTPCC
+1 QUIT
