APCDXPOV ; IHS/CMI/LAB - POV LOOKUP ;
;;2.0;IHS PCC SUITE;**11,20**;MAY 14, 2009;Build 25
;
START ;
S (APCDLOOK,APCDTNQP)=""
D EN^XBNEW("START1^APCDXPOV","APCDTSKI;APCDTDA;APCDLOOK;APCDDATE;APCDTERR;APCDPAT;DFN;APCDTNQP;APCDTPCC;APCDTDIA;APCDVSIT;APCDINAD;BDGV")
Q
START1 ;EP
S APCDTPCC="",APCDINPE=1,APCDD=""
;FOR NOW IF ICD9 CALL LEX, AFTER VA SENDS OUT ICD10 LEX JUST D LEX Q
NEW %,D
S D=""
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="",$G(BDGV),$D(^AUPNVSIT(BDGV,0)) D
.S APCDD=$P($P(^AUPNVSIT(BDGV,0),U),".")
I APCDD="" S APCDD=DT
I S APCDIMP=$$IMP^AUPNSICD(APCDD)
;
LEX ;EP - called from input template
;reader call to get TEXT for code
K DIR
K ^TMP("LEXSCH",$J)
I APCDIMP=1 D CONFIG^LEXSET("ICD","ICD",$P(APCDD,"."))
I APCDIMP=30 D CONFIG^LEXSET("10D","10D",$P(APCDD,"."))
S DIR(0)="FO^1:60",DIR("A")=$S($G(APCDTDIA)]"":APCDTDIA,1:"Enter PURPOSE OF VISIT")
S DIR("?")="^D HELPADX^AUPNSICA"
S DIR("??")="^D HELPADX^AUPNSICA"
KILL DA
I $G(APCDTDA),$$VAL^XBDIQ1(9000010.02,APCDTDA,.12)]"" S DIR("B")=$$VAL^XBDIQ1(9000010.02,APCDTDA,.12)
D ^DIR KILL DIR
I $D(DIRUT) S APCDTSKI=1,APCDLOOK="" G XITL
I Y="" S APCDTSKI=1,APCDLOOK="" G XITL
S APCDUINP=Y
I APCDUINP=$$VAL^XBDIQ1(9000010.02,APCDTDA,.12) G XITL
I APCDIMP=1 D CONFIG^LEXSET("ICD","ICD",$P(APCDD,"."))
I APCDIMP=30 D CONFIG^LEXSET("10D","10D",$P(APCDD,"."))
S X=APCDUINP
S %=""
I X="@" W !!,"Admitting Diagnosis is Required." G LEX
I APCDUINP=".9999" S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999")) G LEXN
I APCDIMP=30,APCDUINP="ZZZ.999" S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999")) G LEXN
I APCDIMP=30,$E(APCDUINP,1,4)="ZZZ." S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999")) G LEXN
I $E(APCDUINP,1,7)="UNCODED" S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999")) G LEXN
I APCDUINP["UNCODED D" S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999")) G LEXN
I APCDIMP=1 S DIC("S")="I $$ICDONE9^APCDXPOV(+Y,LEXVDT)"
I APCDIMP=30 S DIC("S")="I $$ICDONE1^APCDXPOV(+Y,LEXVDT)"
S DIC("A")=$S($G(APCDTDIA)]"":APCDTDIA_": ",1:"Enter Admitting Diagnosis: ")
I APCDIMP=1 D LOOK^LEXA(X,"ICD",999,"ICD",$P(APCDD,"."))
I APCDIMP=30 D LOOK^LEXA(X,"10D",999,"10D",$P(APCDD,"."))
I 'LEX D G:%="" LEX G:% LEXN
.S X=0 F S X=$O(LEX("HLP",X)) Q:X'=+X W !,LEX("HLP",X)
.;now check fileman V2.0 PATCH 20 CR#554
.W !!,"now trying secondary fileman lookup..."
.S %="" S X=APCDUINP,DIC="^ICD9(",DIC(0)="MEQ",DIC("S")="D ^AUPNSICD" D ^DIC K DIC
.S %="" I $P(Y,U)'=-1 S %=+Y
;display all codes and call reader
S APCDANS=""
D GETANS^APCDAPOV
I APCDY="^" W ! D G:%="" LEX G:% LEXN
.;now check fileman
.;W !!,"now trying fileman lookup..."
.S %="" ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="QME" D ^DIC K DIC
.;S %="" I $P(Y,U)'=-1 S %=+Y
I APCDY="" W ! D G:%="" LEX G:% LEXN
.;now check fileman
.;W !!,"now trying fileman lookup..."
.S %="" ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="MEQ" D ^DIC K DIC
.;S %="" I $P(Y,U)'=-1 S %=+Y
I '$G(APCDY) W ! D G:%="" LEX G:% LEXN
.;now check fileman
.;W !!,"now trying fileman lookup..."
.S %="" ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="MEQ" D ^DIC K DIC
.;S %="" I $P(Y,U)'=-1 S %=+Y
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,APCDLOOK="" G XITL
S %=$$ICDDX^ICDEX(Y,$P(APCDD,"."),APCDIMP,"E")
I $P(%,U,1)="-1" W !!,"lexicon isn't passing back an ICD code." S APCDTERR=1,APCDLOOK="" G XITL
LEXN ;
S APCDLOOK="`"_+%,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:'$$CHK^AUPNSICA($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,ALEVXDT,%
S ALEX=$$ONE^LEXU(ALEX,ALEXVDT,"10D") Q:ALEX="" ""
S ALEXICD=$$ICDDX^ICDEX(ALEX,ALEXVDT,30,"E")
Q:$P(ALEXICD,"^",2)="INVALID CODE" ""
Q:'$$CHK^AUPNSICA($P(ALEXICD,U,1)) ""
Q 1
EDIT01 ;EP
D EN^XBNEW("EDIT011^APCDXPOV","APCDTDA;APCDVSIT;APCDPAT;APCDDATE;DFN;AUPNPAT;AUPNVSIT;APCDTTMP;BDGV")
Q
EDIT011 ;
K DIE,DA,DR
;
1 ;EDIT .12 OF V HOSP
W !
K DIR
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="",$G(BDGV),$D(^AUPNVSIT(BDGV,0)) D
.S APCDD=$P($P(^AUPNVSIT(BDGV,0),U),".")
I APCDD="" S APCDD=DT
S APCDHDAT=APCDD
;12
W !!,"Please Note: Admitting Diagnosis is Required.",!
S APCDIMP=$$IMP^AUPNSICD(APCDD)
S APCDTFIE=".12",APCDTDIA="ADMITTING DX",APCDTDEL="",APCDLOOK="" K APCDINAD
D LEX
I $G(APCDTSKI) Q ;"^" OUT
I APCDLOOK]"" S DA=APCDTDA,DIE="^AUPNVINP(",DR=".12///"_APCDLOOK D ^DIE K DA,DIE,DR
I $$VAL^XBDIQ1(9000010.02,APCDTDA,.12)="" G 1
Q
APCDXPOV ; IHS/CMI/LAB - POV LOOKUP ;
+1 ;;2.0;IHS PCC SUITE;**11,20**;MAY 14, 2009;Build 25
+2 ;
START ;
+1 SET (APCDLOOK,APCDTNQP)=""
+2 DO EN^XBNEW("START1^APCDXPOV","APCDTSKI;APCDTDA;APCDLOOK;APCDDATE;APCDTERR;APCDPAT;DFN;APCDTNQP;APCDTPCC;APCDTDIA;APCDVSIT;APCDINAD;BDGV")
+3 QUIT
START1 ;EP
+1 SET APCDTPCC=""
SET APCDINPE=1
SET APCDD=""
+2 ;FOR NOW IF ICD9 CALL LEX, AFTER VA SENDS OUT ICD10 LEX JUST D LEX Q
+3 NEW %,D
+4 SET D=""
+5 IF $GET(APCDVSIT)
IF $DATA(^AUPNVSIT(APCDVSIT))
Begin DoDot:1
+6 ;I $P(^AUPNVSIT(APCDVSIT,0),U,7)="H",$$DSCHDATE^APCLV(APCDVSIT)]"" S APCDD=$$DSCHDATE^APCLV(APCDVSIT) Q
+7 SET APCDD=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")
End DoDot:1
+8 IF APCDD=""
SET APCDD=$PIECE($GET(APCDDATE),".")
+9 IF APCDD=""
IF $GET(BDGV)
IF $DATA(^AUPNVSIT(BDGV,0))
Begin DoDot:1
+10 SET APCDD=$PIECE($PIECE(^AUPNVSIT(BDGV,0),U),".")
End DoDot:1
+11 IF APCDD=""
SET APCDD=DT
I SET APCDIMP=$$IMP^AUPNSICD(APCDD)
+1 ;
LEX ;EP - called from input template
+1 ;reader call to get TEXT for code
+2 KILL DIR
+3 KILL ^TMP("LEXSCH",$JOB)
+4 IF APCDIMP=1
DO CONFIG^LEXSET("ICD","ICD",$PIECE(APCDD,"."))
+5 IF APCDIMP=30
DO CONFIG^LEXSET("10D","10D",$PIECE(APCDD,"."))
+6 SET DIR(0)="FO^1:60"
SET DIR("A")=$SELECT($GET(APCDTDIA)]"":APCDTDIA,1:"Enter PURPOSE OF VISIT")
+7 SET DIR("?")="^D HELPADX^AUPNSICA"
+8 SET DIR("??")="^D HELPADX^AUPNSICA"
+9 KILL DA
+10 IF $GET(APCDTDA)
IF $$VAL^XBDIQ1(9000010.02,APCDTDA,.12)]""
SET DIR("B")=$$VAL^XBDIQ1(9000010.02,APCDTDA,.12)
+11 DO ^DIR
KILL DIR
+12 IF $DATA(DIRUT)
SET APCDTSKI=1
SET APCDLOOK=""
GOTO XITL
+13 IF Y=""
SET APCDTSKI=1
SET APCDLOOK=""
GOTO XITL
+14 SET APCDUINP=Y
+15 IF APCDUINP=$$VAL^XBDIQ1(9000010.02,APCDTDA,.12)
GOTO XITL
+16 IF APCDIMP=1
DO CONFIG^LEXSET("ICD","ICD",$PIECE(APCDD,"."))
+17 IF APCDIMP=30
DO CONFIG^LEXSET("10D","10D",$PIECE(APCDD,"."))
+18 SET X=APCDUINP
+19 SET %=""
+20 IF X="@"
WRITE !!,"Admitting Diagnosis is Required."
GOTO LEX
+21 IF APCDUINP=".9999"
SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"))
GOTO LEXN
+22 IF APCDIMP=30
IF APCDUINP="ZZZ.999"
SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"))
GOTO LEXN
+23 IF APCDIMP=30
IF $EXTRACT(APCDUINP,1,4)="ZZZ."
SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"))
GOTO LEXN
+24 IF $EXTRACT(APCDUINP,1,7)="UNCODED"
SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"))
GOTO LEXN
+25 IF APCDUINP["UNCODED D"
SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"))
GOTO LEXN
+26 IF APCDIMP=1
SET DIC("S")="I $$ICDONE9^APCDXPOV(+Y,LEXVDT)"
+27 IF APCDIMP=30
SET DIC("S")="I $$ICDONE1^APCDXPOV(+Y,LEXVDT)"
+28 SET DIC("A")=$SELECT($GET(APCDTDIA)]"":APCDTDIA_": ",1:"Enter Admitting Diagnosis: ")
+29 IF APCDIMP=1
DO LOOK^LEXA(X,"ICD",999,"ICD",$PIECE(APCDD,"."))
+30 IF APCDIMP=30
DO LOOK^LEXA(X,"10D",999,"10D",$PIECE(APCDD,"."))
+31 IF 'LEX
Begin DoDot:1
+32 SET X=0
FOR
SET X=$ORDER(LEX("HLP",X))
IF X'=+X
QUIT
WRITE !,LEX("HLP",X)
+33 ;now check fileman V2.0 PATCH 20 CR#554
+34 WRITE !!,"now trying secondary fileman lookup..."
+35 SET %=""
SET X=APCDUINP
SET DIC="^ICD9("
SET DIC(0)="MEQ"
SET DIC("S")="D ^AUPNSICD"
DO ^DIC
KILL DIC
+36 SET %=""
IF $PIECE(Y,U)'=-1
SET %=+Y
End DoDot:1
IF %=""
GOTO LEX
IF %
GOTO LEXN
+37 ;display all codes and call reader
+38 SET APCDANS=""
+39 DO GETANS^APCDAPOV
+40 IF APCDY="^"
WRITE !
Begin DoDot:1
+41 ;now check fileman
+42 ;W !!,"now trying fileman lookup..."
+43 ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="QME" D ^DIC K DIC
SET %=""
+44 ;S %="" I $P(Y,U)'=-1 S %=+Y
End DoDot:1
IF %=""
GOTO LEX
IF %
GOTO LEXN
+45 IF APCDY=""
WRITE !
Begin DoDot:1
+46 ;now check fileman
+47 ;W !!,"now trying fileman lookup..."
+48 ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="MEQ" D ^DIC K DIC
SET %=""
+49 ;S %="" I $P(Y,U)'=-1 S %=+Y
End DoDot:1
IF %=""
GOTO LEX
IF %
GOTO LEXN
+50 IF '$GET(APCDY)
WRITE !
Begin DoDot:1
+51 ;now check fileman
+52 ;W !!,"now trying fileman lookup..."
+53 ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="MEQ" D ^DIC K DIC
SET %=""
+54 ;S %="" I $P(Y,U)'=-1 S %=+Y
End DoDot:1
IF %=""
GOTO LEX
IF %
GOTO LEXN
+55 IF APCDIMP=1
SET Y=$$ICDONE^LEXU($PIECE(^TMP("LEXHIT",$JOB,APCDY),U,1),$PIECE(APCDD,"."))
+56 IF APCDIMP=30
SET Y=$$ONE^LEXU($PIECE(^TMP("LEXHIT",$JOB,APCDY),U,1),$PIECE(APCDD,"."),"10D")
+57 KILL DO,^TMP("LEXSCH",$JOB)
+58 IF $GET(Y)=""
WRITE !!,"lexicon isn't passing back an ICD code."
SET APCDTERR=1
SET APCDLOOK=""
GOTO XITL
+59 SET %=$$ICDDX^ICDEX(Y,$PIECE(APCDD,"."),APCDIMP,"E")
+60 IF $PIECE(%,U,1)="-1"
WRITE !!,"lexicon isn't passing back an ICD code."
SET APCDTERR=1
SET APCDLOOK=""
GOTO XITL
LEXN ;
+1 SET APCDLOOK="`"_+%
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 '$$CHK^AUPNSICA($PIECE(ALEXICD,U,1))
QUIT ""
+9 QUIT 1
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,ALEVXDT,%
+4 SET ALEX=$$ONE^LEXU(ALEX,ALEXVDT,"10D")
IF ALEX=""
QUIT ""
+5 SET ALEXICD=$$ICDDX^ICDEX(ALEX,ALEXVDT,30,"E")
+6 IF $PIECE(ALEXICD,"^",2)="INVALID CODE"
QUIT ""
+7 IF '$$CHK^AUPNSICA($PIECE(ALEXICD,U,1))
QUIT ""
+8 QUIT 1
EDIT01 ;EP
+1 DO EN^XBNEW("EDIT011^APCDXPOV","APCDTDA;APCDVSIT;APCDPAT;APCDDATE;DFN;AUPNPAT;AUPNVSIT;APCDTTMP;BDGV")
+2 QUIT
EDIT011 ;
+1 KILL DIE,DA,DR
+2 ;
1 ;EDIT .12 OF V HOSP
+1 WRITE !
+2 KILL DIR
+3 SET APCDD=""
+4 IF $GET(APCDVSIT)
IF $DATA(^AUPNVSIT(APCDVSIT))
Begin DoDot:1
+5 ;I $P(^AUPNVSIT(APCDVSIT,0),U,7)="H",$$DSCHDATE^APCLV(APCDVSIT)]"" S APCDD=$$DSCHDATE^APCLV(APCDVSIT) Q
+6 SET APCDD=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")
End DoDot:1
+7 IF APCDD=""
SET APCDD=$PIECE($GET(APCDDATE),".")
+8 IF APCDD=""
IF $GET(BDGV)
IF $DATA(^AUPNVSIT(BDGV,0))
Begin DoDot:1
+9 SET APCDD=$PIECE($PIECE(^AUPNVSIT(BDGV,0),U),".")
End DoDot:1
+10 IF APCDD=""
SET APCDD=DT
+11 SET APCDHDAT=APCDD
+12 ;12
+13 WRITE !!,"Please Note: Admitting Diagnosis is Required.",!
+14 SET APCDIMP=$$IMP^AUPNSICD(APCDD)
+15 SET APCDTFIE=".12"
SET APCDTDIA="ADMITTING DX"
SET APCDTDEL=""
SET APCDLOOK=""
KILL APCDINAD
+16 DO LEX
+17 ;"^" OUT
IF $GET(APCDTSKI)
QUIT
+18 IF APCDLOOK]""
SET DA=APCDTDA
SET DIE="^AUPNVINP("
SET DR=".12///"_APCDLOOK
DO ^DIE
KILL DA,DIE,DR
+19 IF $$VAL^XBDIQ1(9000010.02,APCDTDA,.12)=""
GOTO 1
+20 QUIT
