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

APCDEPOV.m

Go to the documentation of this file. 
  1. APCDEPOV ; IHS/CMI/LAB - POV LOOKUP ; 01 Apr 2015  3:18 PM
  1.  ;;2.0;IHS PCC SUITE;**11,13,16,20**;MAY 14, 2009;Build 25
  1.  ;
  1. EDIT01 ;EP
  1.  D EN^XBNEW("EDIT011^APCDEPOV","APCDTDA;APCDVSIT;APCDPAT;APCDDATE;DFN;AUPNPAT;AUPNVSIT;APCDTTMP")
  1.  Q
  1. EDIT011 ;
  1.  K DIE,DA,DR
  1.  S APCDOVRR=1
  1.  ;
  1. 1 ;EDIT .01 FIELD OF V POV
  1.  W !
  1.  K DIR
  1.  S APCDD=""
  1.  S APCDIAIE=1  ;i am in edit mode
  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.  S APCDHDAT=APCDD
  1.  ;
  1.  S APCDIMP=$$IMP^AUPNSICD(APCDD)
  1.  S APCDTFIE=".01",APCDTDIA="POV",APCDTDEL="",APCDTNPV=""
  1.  D LEX
  1.  I $G(APCDTDEL) D DELETE
  1.  I $G(APCDTDEL) Q  ;deleted the v pov
  1.  I $G(APCDTSKI) Q  ;"^" OUT
  1.  I $G(APCDTNPV)="" G 2
  1.  S DIE="^AUPNVPOV(",DA=APCDTDA,DR=".01///"_APCDTNPV D ^DIE K DIE,DA,DR
  1.  I $D(Y) W !?5,"??" G 1
  1. 2 ;DUAL CODING .24
  1.  S APCDIMP=$$IMP^AUPNSICD(APCDD)
  1.  I APCDIMP=1 G 3  ;no dual for icd9 environment
  1.  I '$P($G(^APCDSITE(DUZ(2),0)),U,36) G 3  ;dual coding off
  1.  D K
  1.  S APCDTIN9=1,APCDTDIA="ICD-9 CODE",APCDTDEL="",APCDTNPV="",APCDTFIE=".24",APCDIMP=""
  1.  S APCDD=$$FMADD^XLFDT($$IMP^AUPNVUTL(30),-2),APCDIMP=1
  1.  D LEX
  1.  I $G(APCDTDEL) D DELETE
  1.  I $G(APCDTDEL) G 3
  1.  I $G(APCDTSKI) Q  ;"^" OUT
  1.  I $G(APCDTNPV)="" G 3
  1.  K DIE,DA,DR
  1.  S DIE="^AUPNVPOV(",DA=APCDTDA,DR=".24///"_APCDTNPV  D ^DIE K DA,DR,DIE
  1.  I $D(Y) W !,"??  " G 2
  1. 3 ;
  1.  ;W !!,"Please Note:  '^'ing is not allowed with the remainder of this mnemonic."
  1.  ;W !,"You must press enter through each field.",!
  1.  ;PROVIDER NARRATIVE
  1.  D K
  1.  I $P($G(^AUPNVPOV(APCDTDA,11)),U,1)]"" D  G 4
  1.  .W !!?5,"PROVIDER NARRATIVE: ",$$VAL^XBDIQ1(9000010.07,APCDTDA,.04),!!
  1.  I $G(APCDTTMP)="IPV" D  G 4
  1.  .S APCDTNQ=$E($P($$ICDDX^ICDEX($P(^AUPNVPOV(APCDTDA,0),U,1),APCDD,,,"I"),U,4),1,140)_"     ****ICD****"
  1.  .S DA=APCDTDA,DIE="^AUPNVPOV(",DR=".04///"_APCDTNQ,DIE("NO^")=1 D ^DIE K DIE,DA,DR
  1.  .W !!,"PROVIDER NARRATIVE: ",$$VAL^XBDIQ1(9000010.07,APCDTDA,.04)
  1. NA ;
  1.  K DIR S DIR(0)="9000010.07,.04",DIR("A")="PROVIDER NARRATIVE",DIR("B")=$$VAL^XBDIQ1(9000010.07,APCDTDA,.04) KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) Q  ;^
  1.  I X["|" D EN^DDIOL("A vertical bar '|' is not allowed in the provider narrative") G NA
  1.  S APCDTNQ=+Y
  1.  S DA=APCDTDA,DIE="^AUPNVPOV(",DR=".04////"_APCDTNQ D ^DIE K DIE,DA,DR
  1.  ;S APCDTOLD=$$VAL^XBDIQ1(9000010.07,APCDTDA,.04)
  1.  ;S APCDTNQ=$$GETNARR^APCDEA3($G(APCDTNQP),APCDTOLD)
  1.  ;I APCDTNQ'=APCDTOLD S DA=APCDTDA,DIE="^AUPNVPOV(",DR=".04///"_APCDTNQ D ^DIE K DIE,DA,DR
  1. 4 ;PRESENT ON ADMISSION/PRIMARY/SECONDAY H VISITS ONLY
  1.  D K
  1.  S APCDTIMH=""
  1.  S DIE="^AUPNVPOV(",DA=APCDTDA,DR="[APCD EDIT POV]" D ^DIE K DIE,DA,DR
  1.  I '$G(APCDTIMH) Q
  1. 89 ;
  1.  D K
  1.  D 8
  1.  I $G(APCDTUPH) Q
  1.  D 10
  1.  I $G(APCDTUPH) Q
  1.  D 12
  1.  I $G(APCDTUPH) Q
  1. 14 ;
  1.  D K
  1.  D POC
  1.  I $G(APCDTUPH) Q
  1. 17 ;
  1.  S DA=APCDTDA,DIE="^AUPNVPOV(",DR=".13;.08;1204" D ^DIE K DIE,DA,DR
  1.  Q
  1. K ;
  1.  K DIE,DA,DR,DIR
  1.  K APCDTDEL,APCDTNPV,APCDTFIE,APCDTDIA,APCDIMP,APCDTIN9,APCDTUPH
  1.  Q
  1. 8 ;EP -.09 CAUSE 1
  1.  D K
  1.  K DIR
  1.  S APCDD=APCDHDAT
  1.  ;
  1.  S APCDIMP=$$IMP^AUPNSICD(APCDD)
  1.  S APCDTFIE=".09",APCDTDIA=$S(APCDIMP=30:"CAUSE (V00-Y99 Code Range)",1:"CAUSE (E-Code)"),APCDTDEL="",APCDTNPV=""
  1.  D CLEX^APCDCPOV
  1.  I $G(APCDTDEL) D DELETE
  1.  I $G(APCDTUPH) Q
  1.  I $G(APCDTNPV)="" G 9
  1.  S DIE="^AUPNVPOV(",DA=APCDTDA,DR=".09///"_APCDTNPV D ^DIE K DIE,DA,DR
  1.  I $D(Y) W !?5,"??" G 8
  1. 9 ;DUAL CODE .25
  1.  S APCDIMP=$$IMP^AUPNSICD(APCDD)
  1.  I APCDIMP=1 Q  ;no dual for icd9 environment
  1.  I '$P($G(^APCDSITE(DUZ(2),0)),U,36) Q  ;dual coding off
  1.  D K
  1.  S APCDTIN9=1,APCDTDIA="CAUSE (E-code)",APCDTDEL="",APCDTNPV="",APCDTFIE=".25",APCDIMP=""
  1.  K APCDTUPH
  1.  S APCDD=$$FMADD^XLFDT($$IMP^AUPNVUTL(30),-2),APCDIMP=1
  1.  D CLEX^APCDCPOV
  1.  I $G(APCDTDEL) D DELETE
  1.  I $G(APCDTUPH) Q
  1.  I $G(APCDTDEL) Q
  1.  I $G(APCDTNPV)="" Q
  1.  K DIE,DA,DR
  1.  S DIE="^AUPNVPOV(",DA=APCDTDA,DR=".25///"_APCDTNPV  D ^DIE K DA,DR,DIE
  1.  I $D(Y) W !,"??  " G 9
  1.  Q
  1. 10 ;.18
  1.  D K
  1.  K DIR
  1.  S APCDD=APCDHDAT
  1.  ;
  1.  S APCDIMP=$$IMP^AUPNSICD(APCDD)
  1.  S APCDTFIE=".18",APCDTDIA=$S(APCDIMP=30:"CAUSE (V00-Y99 Code Range) #2",1:"CAUSE (E-Code) #2"),APCDTDEL="",APCDTNPV=""
  1.  K APCDTUPH
  1.  D CLEX^APCDCPOV
  1.  I $G(APCDTDEL) D DELETE
  1.  I $G(APCDTUPH) Q
  1.  I $G(APCDTNPV)="" G 11
  1.  S DIE="^AUPNVPOV(",DA=APCDTDA,DR=".18///"_APCDTNPV D ^DIE K DIE,DA,DR
  1.  I $D(Y) W !?5,"??" G 10
  1. 11 ;DUAL CODE .26
  1.  S APCDIMP=$$IMP^AUPNSICD(APCDD)
  1.  I APCDIMP=1 Q  ;no dual for icd9 environment
  1.  I '$P($G(^APCDSITE(DUZ(2),0)),U,36) Q  ;dual coding off
  1.  D K
  1.  S APCDTIN9=1,APCDTDIA="CAUSE (E-code) #2",APCDTDEL="",APCDTNPV="",APCDTFIE=".26",APCDIMP=""
  1.  S APCDD=$$FMADD^XLFDT($$IMP^AUPNVUTL(30),-2),APCDIMP=1
  1.  K APCDTUPH
  1.  D CLEX^APCDCPOV
  1.  I $G(APCDTDEL) D DELETE
  1.  I $G(APCDTDEL) Q
  1.  I $G(APCDTUPH) Q
  1.  I $G(APCDTNPV)="" Q
  1.  K DIE,DA,DR
  1.  S DIE="^AUPNVPOV(",DA=APCDTDA,DR=".26///"_APCDTNPV  D ^DIE K DA,DR,DIE
  1.  I $D(Y) W !,"??  " G 11
  1.  Q
  1. 12 ;.19
  1.  D K
  1.  K DIR
  1.  S APCDD=APCDHDAT
  1.  ;
  1.  S APCDIMP=$$IMP^AUPNSICD(APCDD)
  1.  S APCDTFIE=".19",APCDTDIA=$S(APCDIMP=30:"CAUSE (V00-Y99 Code Range) #3",1:"CAUSE (E-Code) #3"),APCDTDEL="",APCDTNPV=""
  1.  K APCDTUPH
  1.  D CLEX^APCDCPOV
  1.  I $G(APCDTDEL) D DELETE
  1.  I $G(APCDTUPH) Q
  1.  I $G(APCDTNPV)="" G 13
  1.  S DIE="^AUPNVPOV(",DA=APCDTDA,DR=".19///"_APCDTNPV D ^DIE K DIE,DA,DR
  1.  I $D(Y) W !?5,"??" G 12
  1. 13 ;DUAL CODE .27
  1.  S APCDIMP=$$IMP^AUPNSICD(APCDD)
  1.  I APCDIMP=1 Q  ;no dual for icd9 environment
  1.  I '$P($G(^APCDSITE(DUZ(2),0)),U,36) Q  ;dual coding off
  1.  D K
  1.  S APCDTIN9=1,APCDTDIA="CAUSE (E-code) #3",APCDTDEL="",APCDTNPV="",APCDTFIE=".27",APCDIMP=""
  1.  S APCDD=$$FMADD^XLFDT($$IMP^AUPNVUTL(30),-2),APCDIMP=1
  1.  K APCDTUPH
  1.  D CLEX^APCDCPOV
  1.  I $G(APCDTDEL) D DELETE
  1.  I $G(APCDTDEL) Q
  1.  I $G(APCDTUPH) Q
  1.  I $G(APCDTNPV)="" Q
  1.  K DIE,DA,DR
  1.  S DIE="^AUPNVPOV(",DA=APCDTDA,DR=".26///"_APCDTNPV  D ^DIE K DA,DR,DIE
  1.  I $D(Y) W !,"??  " G 13
  1.  Q
  1. POC ;EP
  1. 141 ;RFB
  1.  D K
  1.  K DIR,DIRUT
  1.  S APCDD=APCDHDAT
  1.  ;
  1.  S APCDIMP=$$IMP^AUPNSICD(APCDD)
  1.  I APCDIMP=1 G 15  ;NOT IN ICD9
  1.  S APCDTFIE=".23",APCDTDIA="RETAINED FOREIGN BODY (Z18-Z18.9)",APCDTDEL="",APCDTNPV=""
  1.  K APCDTUPH
  1.  D RLEX^APCDBPOV
  1.  I $G(APCDTUPH) Q
  1.  I $G(APCDTDEL) D DELETE
  1.  I $G(APCDTNPV)="" G 15
  1.  S DIE="^AUPNVPOV(",DA=APCDTDA,DR=".23///"_APCDTNPV D ^DIE K DIE,DA,DR
  1.  I $D(Y) W !?5,"??" G 141
  1. 15 ;POC .21/.28
  1.  D K
  1.  K DIR
  1.  S APCDD=APCDHDAT
  1.  ;
  1.  S APCDIMP=$$IMP^AUPNSICD(APCDD)
  1.  S APCDTFIE=".21",APCDTDIA=$S(APCDIMP=30:"PLACE OF OCCURRENCE (Y92-Y92.9)",1:"PLACE OF OCCURRENCE (E849-E849.9)"),APCDTDEL="",APCDTNPV=""
  1.  K APCDTUPH
  1.  D PLEX^APCDLPOV
  1.  I $G(APCDTUPH) Q
  1.  I $G(APCDTDEL) D DELETE
  1.  I $G(APCDTNPV)="" G 16
  1.  S DIE="^AUPNVPOV(",DA=APCDTDA,DR=".21///"_APCDTNPV D ^DIE K DIE,DA,DR
  1.  I $D(Y) W !?5,"??" G 15
  1. 16 ;DUAL CODE .28
  1.  S APCDIMP=$$IMP^AUPNSICD(APCDD)
  1.  I APCDIMP=1 Q  ;no dual for icd9 environment
  1.  I '$P($G(^APCDSITE(DUZ(2),0)),U,36) Q  ;dual coding off
  1.  D K
  1.  S APCDTIN9=1,APCDTDIA="PLACE OF OCCURRENCE (E849-E849.9)",APCDTDEL="",APCDTNPV="",APCDTFIE=".28",APCDIMP=""
  1.  S APCDD=$$FMADD^XLFDT($$IMP^AUPNVUTL(30),-2),APCDIMP=1
  1.  K APCDTUPH
  1.  D PLEX^APCDLPOV
  1.  I $G(APCDTUPH) Q
  1.  I $G(APCDTDEL) D DELETE
  1.  I $G(APCDTDEL) Q
  1.  I $G(APCDTNPV)="" Q
  1.  K DIE,DA,DR
  1.  S DIE="^AUPNVPOV(",DA=APCDTDA,DR=".28///"_APCDTNPV  D ^DIE K DA,DR,DIE
  1.  I $D(Y) W !,"??  " G 16
  1.  Q
  1. LEX ;EP - called from input template
  1.  ;reader call to get TEXT for code
  1.  K DIR,APCDTDEL,DIRUT
  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.  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="@" S APCDTDEL=1 G XITL
  1.  I X="" G XITL
  1.  I $D(DIRUT) S APCDTSKI=1 G XITL
  1.  ;I Y="" G XITL
  1.  S APCDUINP=Y
  1.  I APCDUINP=$$VAL^XBDIQ1(9000010.07,APCDTDA,APCDTFIE) G XITL
  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^APCDAPOV
  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,APCDTNPV="" 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,APCDTNPV="" G XITL
  1. LEXN ;
  1.  S APCDTNPV="`"_+%,APCDTNQP=APCDUINP
  1.  W !
  1. XITL K Y,X,DO,D,DD,DIPGM,APCDTPCC
  1.  Q
  1. DELETE ;
  1.  S APCDTDEL=0
  1.  I APCDTFIE=".01" D  Q
  1.  .K DIR
  1.  .S DIR(0)="Y",DIR("A")="   SURE YOU WANT TO DELETE THE ENTIRE V POV" KILL DA D ^DIR KILL DIR
  1.  .I 'Y Q
  1.  .I $D(DIRUT) Q
  1.  .S APCDTDEL=1
  1.  .S DA=APCDTDA,DIK="^AUPNVPOV(" D ^DIK
  1.  K DIR
  1.  S DIR(0)="Y",DIR("A")="   SURE YOU WANT TO DELETE" KILL DA D ^DIR KILL DIR
  1.  I 'Y Q
  1.  I $D(DIRUT) Q
  1.  S DA=APCDTDA,DIE="^AUPNVPOV(",DR=APCDTFIE_"///@" D ^DIE K DIE,DA,DR
  1.  Q
  1. ECOD ;
  1.  ;EP
  1.  D EN^XBNEW("ECOD1^APCDEPOV","APCDTDA;APCDVSIT;APCDPAT;APCDDATE;DFN;AUPNPAT;AUPNVSIT;APCDTTMP")
  1.  Q
  1. ECOD1 ;
  1.  W !
  1.  K DIR
  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.  S APCDHDAT=APCDD
  1.  ;
  1.  S APCDIMP=$$IMP^AUPNSICD(APCDD)
  1.  D 8
  1.  D POC
  1.  Q
  1. ECO2 ;
  1.  ;EP
  1.  D EN^XBNEW("ECO21^APCDEPOV","APCDTDA;APCDVSIT;APCDPAT;APCDDATE;DFN;AUPNPAT;AUPNVSIT;APCDTTMP")
  1.  Q
  1. ECO21 ;
  1.  W !
  1.  K DIR
  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.  S APCDHDAT=APCDD
  1.  ;
  1.  S APCDIMP=$$IMP^AUPNSICD(APCDD)
  1.  D 10
  1.  Q
  1. ECO3 ;
  1.  ;EP
  1.  D EN^XBNEW("ECO31^APCDEPOV","APCDTDA;APCDVSIT;APCDPAT;APCDDATE;DFN;AUPNPAT;AUPNVSIT;APCDTTMP")
  1.  Q
  1. ECO31 ;
  1.  W !
  1.  K DIR
  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.  S APCDHDAT=APCDD
  1.  ;
  1.  S APCDIMP=$$IMP^AUPNSICD(APCDD)
  1.  D 12
  1.  Q