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

APCDAPOV.m

Go to the documentation of this file. 
  1. APCDAPOV ; IHS/CMI/LAB - POV LOOKUP ; 13 Feb 2014  2:26 PM
  1.  ;;2.0;IHS PCC SUITE;**10,11,13,20**;MAY 14, 2009;Build 25
  1.  ;
  1. START ;
  1.  S (APCDLOOK,APCDTNQP)=""
  1.  D EN^XBNEW("START1^APCDAPOV","APCDTSKI;APCDLOOK;APCDDATE;APCDTERR;APCDPAT;DFN;APCDTNQP;APCDTPCC;APCDTDIA;APCDVSIT;APCDINAD,APCDTIN9")
  1.  Q
  1. START1 ;EP
  1.  S APCDTPCC="",APCDINPE=1
  1.  I $G(APCDTIN9) S APCDD=$$FMADD^XLFDT($$IMP^AUPNVUTL(30),-2),APCDIMP=1 G LEX
  1.  S APCDD=""
  1.  I $G(APCDINAD) S APCDD=$S($D(APCDDATE):APCDDATE,1:DT) G I
  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. I ;
  1.  S APCDIMP=$$IMP^AUPNSICD(APCDD)
  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("?")=$S($G(APCDTIN9):"^D HELP9^AUPNSIC9",1:"^D HELP^AUPNSICH")
  1.  S DIR("??")=$S($G(APCDTIN9):"^D HELP9^AUPNSIC9",1:"^D HELP^AUPNSICH")
  1.  KILL DA 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.  S %=""
  1.  I APCDUINP=".9999" S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999"),,APCDIMP,"E") 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.  K ^TMP("LEXSCH",$J),^TMP("LEXHIT",$J),LEX,^TMP("LEXFND",$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 X=APCDUINP
  1.  I APCDIMP=1 S DIC("S")=$S('$G(APCDTIN9):"I $$ICDONE9^APCDAPOV(+Y,LEXVDT)",1:"I $$ICDONE99^APCDAPOV(+Y,LEXVDT)")
  1.  I APCDIMP=30 S DIC("S")="I $$ICDONE1^APCDAPOV(+Y,LEXVDT)"
  1.  S DIC("A")=$S($G(APCDTDIA)]"":APCDTDIA_": ",1:"Enter PURPOSE OF VISIT: ")
  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
  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,"."),,"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. CAUSE(C,S) ;EP
  1.  ;C IS IEN, S IS CODING SYSTEM
  1.  S C=$P($$ICDDX^ICDEX(C,,,"I"),U,2)
  1.  NEW %
  1.  S %=0
  1.  I S=1 D  Q %
  1.  .I $E(C,1)="E" S %=1 Q
  1.  I $E(C,1)="V" S %=1  ;only codes V00-Y99 per Leslie Racine.
  1.  I $E(C,1)="W" S %=1
  1.  I $E(C,1)="X" S %=1
  1.  I $E(C,1)="Y" S %=1
  1.  Q %
  1. INJ(C,S) ;EP
  1.  NEW %
  1.  S %=""
  1.  I S=1 D  Q %
  1.  .I $E(C,1)="E" S %=0 Q
  1.  .I $E(C,1)="V" S %=0 Q
  1.  .I $P(C,".",1)<800 S %=0 Q
  1.  .S %=1
  1.  I $E(C,1)="S" Q 1
  1.  I $E(C,1)="T",$E(C,2,3)<89 Q 1
  1.  Q 0
  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^AUPNSICD($P(ALEXICD,U,1)) ""
  1.  Q 1
  1. ICDONE99(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:'$$CHK91^AUPNSIC9($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^AUPNSICD($P(ALEXICD,U,1)) ""
  1.  Q 1
  1. TEST10 ;
  1.  K ^TMP("LEXSCH"),^TMP("LEXFND"),LEX("LIST")
  1.  K LEX
  1.  S APCDDATE=DT
  1.  D CONFIG^LEXSET("10D","10D",$S(APCDDATE>3141001:APCDDATE,1:3141001))
  1.  S DIC("S")="I $$ICDONE1^APCDAPOV(+Y,LEXVDT)"
  1.  S APCDDATE=DT
  1.  D LOOK^LEXA("HYPERTENSION","10D",999,"10D",$S(APCDDATE>3141001:APCDDATE,1:3141001))
  1.  ;ZW LEX
  1.  Q
  1. GETANS ;EP - DISPLAY LEX ARRAY
  1.  NEW APCDX,APCDZ,APCDQ,APCDCNT,APCDTOT,Z,MF
  1.  S MF=$P(^TMP("LEXHIT",$J,0),U)
  1.  W !!?5,$P(^TMP("LEXHIT",$J,0),U)," term matches found.",!
  1.  S APCDX=0,APCDY="",APCDQ=0,APCDCNT=0,APCDTOT=0
  1.  F  S APCDX=$O(^TMP("LEXHIT",$J,APCDX)) Q:APCDX'=+APCDX!(APCDY]"")  D
  1. DISP .;display code
  1.  .K ^UTILITY($J,"W")
  1.  .W !?3,APCDX,")"
  1.  .S APCDZ=$P(^TMP("LEXHIT",$J,APCDX),U,2)
  1.  .I APCDZ'["(ICD-" S APCDZ=APCDZ_" (ICD-"_$S(APCDIMP=1:9,1:10)_"-CM "_$$ONE^LEXU($P(^TMP("LEXHIT",$J,APCDX),U,1),LEXVDT,$S(APCDIMP=1:"ICD",1:"10D"))_")"
  1.  .S X=APCDZ,DIWL=0,DIWR=70 D ^DIWP
  1.  .S Z=0 F  S Z=$O(^UTILITY($J,"W",0,Z)) Q:Z'=+Z  W:Z>1 ! W ?9,^UTILITY($J,"W",0,Z,0)
  1.  .; APCDCNT=APCDCNT+1,APCDTOT=APCDTOT+1
  1.  .S APCDCNT=APCDCNT+1,APCDTOT=APCDTOT+1
  1.  .I MF=1 S APCDCNT=1,APCDTOT=1 D READ S:APCDY="" APCDY="^" Q
  1.  .I MF>4,APCDCNT=5!(MF=APCDTOT) D READ S APCDCNT=0 Q
  1.  .I MF<5,MF=APCDX D READ S APCDNT=0 Q:APCDY]""
  1.  .Q
  1.  Q
  1. READ ;
  1.  K DIR,DIRUT
  1.  S APCDY=""
  1.  W !
  1.  ;W !,"Type ""^"" to STOP, press ENTER to continue the list or SELECT 1-"_APCDTOT
  1.  S DIR("B")=$S(MF=1:1,1:""),DIR(0)="NO^1:"_APCDTOT_":0"
  1.  S DIR("A")="Type ""^"" to STOP or SELECT 1-"_APCDTOT
  1.  KILL DA D ^DIR W !
  1.  I $D(DIRUT) S APCDY="^"
  1.  I Y="" S APCDY="" Q
  1.  S APCDY=+Y
  1.  Q
  1. OLD ;EP - called from CPV input template
  1.  I $G(APCDTDIA)["PROBLEM" D START^APCDAPRB Q
  1.  S APCDTPCC=""
  1.  X:$D(^DD(9000010.07,.01,12.1)) ^DD(9000010.07,.01,12.1) S DIC="^ICD9(",DIC(0)="AEMQ",DIC("A")="Enter PURPOSE of VISIT: " D ^DIC K DIC
  1.  G:Y="" XIT
  1.  I Y=-1,X=""!(X="^") S APCDTSKI=1,APCDLOOK="" G XIT
  1.  I Y=-1 S APCDTERR=1,APCDLOOK="" G XIT
  1.  S APCDLOOK="`"_+Y,APCDTNQP=X
  1. XIT K Y,X,DO,D,DD,DIPGM,APCDTPCC
  1.  Q
  1. CINJ ;GET CAUSE OF INJURY CODES FROM LEXICON
  1.  K ^TMP("LEXSCH"),^TMP("LEXFND"),LEX("LIST"),LEX
  1.  D CONFIG^LEXSET("10D","10D",DT)
  1.  S DIC("S")="I $$ICDCIJ^APCDAPOV(+Y,LEXVDT)"
  1.  D LOOK^LEXA("FALL","10D",999,"10D",DT)
  1.  Q
  1. ICDCIJ(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,DT,"10D") Q:ALEX="" ""
  1.  S ALEXICD=$$ICDDX^ICDEX(ALEX,ALEXVDT)
  1.  Q:$P(ALEXICD,"^",2)="INVALID CODE" ""
  1.  Q:'$$CAUSE($P(ALEXICD,U,2),30) ""
  1.  Q 1
  1. GETICD ;
  1.  S Y=$$ONE^LEXU($P(LEX("LIST",73),U,1),DT,"10D")
  1.  W !,Y
  1.  Q