APCDEPOV ; IHS/CMI/LAB - POV LOOKUP ; 01 Apr 2015 3:18 PM
;;2.0;IHS PCC SUITE;**11,13,16,20**;MAY 14, 2009;Build 25
;
EDIT01 ;EP
D EN^XBNEW("EDIT011^APCDEPOV","APCDTDA;APCDVSIT;APCDPAT;APCDDATE;DFN;AUPNPAT;AUPNVSIT;APCDTTMP")
Q
EDIT011 ;
K DIE,DA,DR
S APCDOVRR=1
;
1 ;EDIT .01 FIELD OF V POV
W !
K DIR
S APCDD=""
S APCDIAIE=1 ;i am in edit mode
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
S APCDHDAT=APCDD
;
S APCDIMP=$$IMP^AUPNSICD(APCDD)
S APCDTFIE=".01",APCDTDIA="POV",APCDTDEL="",APCDTNPV=""
D LEX
I $G(APCDTDEL) D DELETE
I $G(APCDTDEL) Q ;deleted the v pov
I $G(APCDTSKI) Q ;"^" OUT
I $G(APCDTNPV)="" G 2
S DIE="^AUPNVPOV(",DA=APCDTDA,DR=".01///"_APCDTNPV D ^DIE K DIE,DA,DR
I $D(Y) W !?5,"??" G 1
2 ;DUAL CODING .24
S APCDIMP=$$IMP^AUPNSICD(APCDD)
I APCDIMP=1 G 3 ;no dual for icd9 environment
I '$P($G(^APCDSITE(DUZ(2),0)),U,36) G 3 ;dual coding off
D K
S APCDTIN9=1,APCDTDIA="ICD-9 CODE",APCDTDEL="",APCDTNPV="",APCDTFIE=".24",APCDIMP=""
S APCDD=$$FMADD^XLFDT($$IMP^AUPNVUTL(30),-2),APCDIMP=1
D LEX
I $G(APCDTDEL) D DELETE
I $G(APCDTDEL) G 3
I $G(APCDTSKI) Q ;"^" OUT
I $G(APCDTNPV)="" G 3
K DIE,DA,DR
S DIE="^AUPNVPOV(",DA=APCDTDA,DR=".24///"_APCDTNPV D ^DIE K DA,DR,DIE
I $D(Y) W !,"?? " G 2
3 ;
;W !!,"Please Note: '^'ing is not allowed with the remainder of this mnemonic."
;W !,"You must press enter through each field.",!
;PROVIDER NARRATIVE
D K
I $P($G(^AUPNVPOV(APCDTDA,11)),U,1)]"" D G 4
.W !!?5,"PROVIDER NARRATIVE: ",$$VAL^XBDIQ1(9000010.07,APCDTDA,.04),!!
I $G(APCDTTMP)="IPV" D G 4
.S APCDTNQ=$E($P($$ICDDX^ICDEX($P(^AUPNVPOV(APCDTDA,0),U,1),APCDD,,,"I"),U,4),1,140)_" ****ICD****"
.S DA=APCDTDA,DIE="^AUPNVPOV(",DR=".04///"_APCDTNQ,DIE("NO^")=1 D ^DIE K DIE,DA,DR
.W !!,"PROVIDER NARRATIVE: ",$$VAL^XBDIQ1(9000010.07,APCDTDA,.04)
NA ;
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
I $D(DIRUT) Q ;^
I X["|" D EN^DDIOL("A vertical bar '|' is not allowed in the provider narrative") G NA
S APCDTNQ=+Y
S DA=APCDTDA,DIE="^AUPNVPOV(",DR=".04////"_APCDTNQ D ^DIE K DIE,DA,DR
;S APCDTOLD=$$VAL^XBDIQ1(9000010.07,APCDTDA,.04)
;S APCDTNQ=$$GETNARR^APCDEA3($G(APCDTNQP),APCDTOLD)
;I APCDTNQ'=APCDTOLD S DA=APCDTDA,DIE="^AUPNVPOV(",DR=".04///"_APCDTNQ D ^DIE K DIE,DA,DR
4 ;PRESENT ON ADMISSION/PRIMARY/SECONDAY H VISITS ONLY
D K
S APCDTIMH=""
S DIE="^AUPNVPOV(",DA=APCDTDA,DR="[APCD EDIT POV]" D ^DIE K DIE,DA,DR
I '$G(APCDTIMH) Q
89 ;
D K
D 8
I $G(APCDTUPH) Q
D 10
I $G(APCDTUPH) Q
D 12
I $G(APCDTUPH) Q
14 ;
D K
D POC
I $G(APCDTUPH) Q
17 ;
S DA=APCDTDA,DIE="^AUPNVPOV(",DR=".13;.08;1204" D ^DIE K DIE,DA,DR
Q
K ;
K DIE,DA,DR,DIR
K APCDTDEL,APCDTNPV,APCDTFIE,APCDTDIA,APCDIMP,APCDTIN9,APCDTUPH
Q
8 ;EP -.09 CAUSE 1
D K
K DIR
S APCDD=APCDHDAT
;
S APCDIMP=$$IMP^AUPNSICD(APCDD)
S APCDTFIE=".09",APCDTDIA=$S(APCDIMP=30:"CAUSE (V00-Y99 Code Range)",1:"CAUSE (E-Code)"),APCDTDEL="",APCDTNPV=""
D CLEX^APCDCPOV
I $G(APCDTDEL) D DELETE
I $G(APCDTUPH) Q
I $G(APCDTNPV)="" G 9
S DIE="^AUPNVPOV(",DA=APCDTDA,DR=".09///"_APCDTNPV D ^DIE K DIE,DA,DR
I $D(Y) W !?5,"??" G 8
9 ;DUAL CODE .25
S APCDIMP=$$IMP^AUPNSICD(APCDD)
I APCDIMP=1 Q ;no dual for icd9 environment
I '$P($G(^APCDSITE(DUZ(2),0)),U,36) Q ;dual coding off
D K
S APCDTIN9=1,APCDTDIA="CAUSE (E-code)",APCDTDEL="",APCDTNPV="",APCDTFIE=".25",APCDIMP=""
K APCDTUPH
S APCDD=$$FMADD^XLFDT($$IMP^AUPNVUTL(30),-2),APCDIMP=1
D CLEX^APCDCPOV
I $G(APCDTDEL) D DELETE
I $G(APCDTUPH) Q
I $G(APCDTDEL) Q
I $G(APCDTNPV)="" Q
K DIE,DA,DR
S DIE="^AUPNVPOV(",DA=APCDTDA,DR=".25///"_APCDTNPV D ^DIE K DA,DR,DIE
I $D(Y) W !,"?? " G 9
Q
10 ;.18
D K
K DIR
S APCDD=APCDHDAT
;
S APCDIMP=$$IMP^AUPNSICD(APCDD)
S APCDTFIE=".18",APCDTDIA=$S(APCDIMP=30:"CAUSE (V00-Y99 Code Range) #2",1:"CAUSE (E-Code) #2"),APCDTDEL="",APCDTNPV=""
K APCDTUPH
D CLEX^APCDCPOV
I $G(APCDTDEL) D DELETE
I $G(APCDTUPH) Q
I $G(APCDTNPV)="" G 11
S DIE="^AUPNVPOV(",DA=APCDTDA,DR=".18///"_APCDTNPV D ^DIE K DIE,DA,DR
I $D(Y) W !?5,"??" G 10
11 ;DUAL CODE .26
S APCDIMP=$$IMP^AUPNSICD(APCDD)
I APCDIMP=1 Q ;no dual for icd9 environment
I '$P($G(^APCDSITE(DUZ(2),0)),U,36) Q ;dual coding off
D K
S APCDTIN9=1,APCDTDIA="CAUSE (E-code) #2",APCDTDEL="",APCDTNPV="",APCDTFIE=".26",APCDIMP=""
S APCDD=$$FMADD^XLFDT($$IMP^AUPNVUTL(30),-2),APCDIMP=1
K APCDTUPH
D CLEX^APCDCPOV
I $G(APCDTDEL) D DELETE
I $G(APCDTDEL) Q
I $G(APCDTUPH) Q
I $G(APCDTNPV)="" Q
K DIE,DA,DR
S DIE="^AUPNVPOV(",DA=APCDTDA,DR=".26///"_APCDTNPV D ^DIE K DA,DR,DIE
I $D(Y) W !,"?? " G 11
Q
12 ;.19
D K
K DIR
S APCDD=APCDHDAT
;
S APCDIMP=$$IMP^AUPNSICD(APCDD)
S APCDTFIE=".19",APCDTDIA=$S(APCDIMP=30:"CAUSE (V00-Y99 Code Range) #3",1:"CAUSE (E-Code) #3"),APCDTDEL="",APCDTNPV=""
K APCDTUPH
D CLEX^APCDCPOV
I $G(APCDTDEL) D DELETE
I $G(APCDTUPH) Q
I $G(APCDTNPV)="" G 13
S DIE="^AUPNVPOV(",DA=APCDTDA,DR=".19///"_APCDTNPV D ^DIE K DIE,DA,DR
I $D(Y) W !?5,"??" G 12
13 ;DUAL CODE .27
S APCDIMP=$$IMP^AUPNSICD(APCDD)
I APCDIMP=1 Q ;no dual for icd9 environment
I '$P($G(^APCDSITE(DUZ(2),0)),U,36) Q ;dual coding off
D K
S APCDTIN9=1,APCDTDIA="CAUSE (E-code) #3",APCDTDEL="",APCDTNPV="",APCDTFIE=".27",APCDIMP=""
S APCDD=$$FMADD^XLFDT($$IMP^AUPNVUTL(30),-2),APCDIMP=1
K APCDTUPH
D CLEX^APCDCPOV
I $G(APCDTDEL) D DELETE
I $G(APCDTDEL) Q
I $G(APCDTUPH) Q
I $G(APCDTNPV)="" Q
K DIE,DA,DR
S DIE="^AUPNVPOV(",DA=APCDTDA,DR=".26///"_APCDTNPV D ^DIE K DA,DR,DIE
I $D(Y) W !,"?? " G 13
Q
POC ;EP
141 ;RFB
D K
K DIR,DIRUT
S APCDD=APCDHDAT
;
S APCDIMP=$$IMP^AUPNSICD(APCDD)
I APCDIMP=1 G 15 ;NOT IN ICD9
S APCDTFIE=".23",APCDTDIA="RETAINED FOREIGN BODY (Z18-Z18.9)",APCDTDEL="",APCDTNPV=""
K APCDTUPH
D RLEX^APCDBPOV
I $G(APCDTUPH) Q
I $G(APCDTDEL) D DELETE
I $G(APCDTNPV)="" G 15
S DIE="^AUPNVPOV(",DA=APCDTDA,DR=".23///"_APCDTNPV D ^DIE K DIE,DA,DR
I $D(Y) W !?5,"??" G 141
15 ;POC .21/.28
D K
K DIR
S APCDD=APCDHDAT
;
S APCDIMP=$$IMP^AUPNSICD(APCDD)
S APCDTFIE=".21",APCDTDIA=$S(APCDIMP=30:"PLACE OF OCCURRENCE (Y92-Y92.9)",1:"PLACE OF OCCURRENCE (E849-E849.9)"),APCDTDEL="",APCDTNPV=""
K APCDTUPH
D PLEX^APCDLPOV
I $G(APCDTUPH) Q
I $G(APCDTDEL) D DELETE
I $G(APCDTNPV)="" G 16
S DIE="^AUPNVPOV(",DA=APCDTDA,DR=".21///"_APCDTNPV D ^DIE K DIE,DA,DR
I $D(Y) W !?5,"??" G 15
16 ;DUAL CODE .28
S APCDIMP=$$IMP^AUPNSICD(APCDD)
I APCDIMP=1 Q ;no dual for icd9 environment
I '$P($G(^APCDSITE(DUZ(2),0)),U,36) Q ;dual coding off
D K
S APCDTIN9=1,APCDTDIA="PLACE OF OCCURRENCE (E849-E849.9)",APCDTDEL="",APCDTNPV="",APCDTFIE=".28",APCDIMP=""
S APCDD=$$FMADD^XLFDT($$IMP^AUPNVUTL(30),-2),APCDIMP=1
K APCDTUPH
D PLEX^APCDLPOV
I $G(APCDTUPH) Q
I $G(APCDTDEL) D DELETE
I $G(APCDTDEL) Q
I $G(APCDTNPV)="" Q
K DIE,DA,DR
S DIE="^AUPNVPOV(",DA=APCDTDA,DR=".28///"_APCDTNPV D ^DIE K DA,DR,DIE
I $D(Y) W !,"?? " G 16
Q
LEX ;EP - called from input template
;reader call to get TEXT for code
K DIR,APCDTDEL,DIRUT
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("?")=$S($G(APCDTIN9):"^D HELP9^AUPNSIC9",1:"^D HELP^AUPNSICH")
S DIR("??")=$S($G(APCDTIN9):"^D HELP9^AUPNSIC9",1:"^D HELP^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="@" S APCDTDEL=1 G XITL
I X="" G XITL
I $D(DIRUT) S APCDTSKI=1 G XITL
;I Y="" G XITL
S APCDUINP=Y
I APCDUINP=$$VAL^XBDIQ1(9000010.07,APCDTDA,APCDTFIE) G XITL
S %=""
I APCDUINP=".9999" S %=+$$ICDDX^ICDEX($S(APCDIMP=1:".9999",1:"ZZZ.999"),,APCDIMP,"E") 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
K ^TMP("LEXSCH",$J),^TMP("LEXHIT",$J),LEX,^TMP("LEXFND",$J)
I APCDIMP=1 D CONFIG^LEXSET("ICD","ICD",$P(APCDD,"."))
I APCDIMP=30 D CONFIG^LEXSET("10D","10D",$P(APCDD,"."))
S X=APCDUINP
I APCDIMP=1 S DIC("S")=$S('$G(APCDTIN9):"I $$ICDONE9^APCDAPOV(+Y,LEXVDT)",1:"I $$ICDONE99^APCDAPOV(+Y,LEXVDT)")
I APCDIMP=30 S DIC("S")="I $$ICDONE1^APCDAPOV(+Y,LEXVDT)"
S DIC("A")=$S($G(APCDTDIA)]"":APCDTDIA_": ",1:"Enter PURPOSE OF VISIT: ")
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,APCDTNPV="" G XITL
S %=$$ICDDX^ICDEX(Y,$P(APCDD,"."),,"E")
I $P(%,U,1)="-1" W !!,"lexicon isn't passing back an ICD code." S APCDTERR=1,APCDTNPV="" G XITL
LEXN ;
S APCDTNPV="`"_+%,APCDTNQP=APCDUINP
W !
XITL K Y,X,DO,D,DD,DIPGM,APCDTPCC
Q
DELETE ;
S APCDTDEL=0
I APCDTFIE=".01" D Q
.K DIR
.S DIR(0)="Y",DIR("A")=" SURE YOU WANT TO DELETE THE ENTIRE V POV" KILL DA D ^DIR KILL DIR
.I 'Y Q
.I $D(DIRUT) Q
.S APCDTDEL=1
.S DA=APCDTDA,DIK="^AUPNVPOV(" D ^DIK
K DIR
S DIR(0)="Y",DIR("A")=" SURE YOU WANT TO DELETE" KILL DA D ^DIR KILL DIR
I 'Y Q
I $D(DIRUT) Q
S DA=APCDTDA,DIE="^AUPNVPOV(",DR=APCDTFIE_"///@" D ^DIE K DIE,DA,DR
Q
ECOD ;
;EP
D EN^XBNEW("ECOD1^APCDEPOV","APCDTDA;APCDVSIT;APCDPAT;APCDDATE;DFN;AUPNPAT;AUPNVSIT;APCDTTMP")
Q
ECOD1 ;
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="" S APCDD=DT
S APCDHDAT=APCDD
;
S APCDIMP=$$IMP^AUPNSICD(APCDD)
D 8
D POC
Q
ECO2 ;
;EP
D EN^XBNEW("ECO21^APCDEPOV","APCDTDA;APCDVSIT;APCDPAT;APCDDATE;DFN;AUPNPAT;AUPNVSIT;APCDTTMP")
Q
ECO21 ;
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="" S APCDD=DT
S APCDHDAT=APCDD
;
S APCDIMP=$$IMP^AUPNSICD(APCDD)
D 10
Q
ECO3 ;
;EP
D EN^XBNEW("ECO31^APCDEPOV","APCDTDA;APCDVSIT;APCDPAT;APCDDATE;DFN;AUPNPAT;AUPNVSIT;APCDTTMP")
Q
ECO31 ;
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="" S APCDD=DT
S APCDHDAT=APCDD
;
S APCDIMP=$$IMP^AUPNSICD(APCDD)
D 12
Q
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
+2 ;
EDIT01 ;EP
+1 DO EN^XBNEW("EDIT011^APCDEPOV","APCDTDA;APCDVSIT;APCDPAT;APCDDATE;DFN;AUPNPAT;AUPNVSIT;APCDTTMP")
+2 QUIT
EDIT011 ;
+1 KILL DIE,DA,DR
+2 SET APCDOVRR=1
+3 ;
1 ;EDIT .01 FIELD OF V POV
+1 WRITE !
+2 KILL DIR
+3 SET APCDD=""
+4 ;i am in edit mode
SET APCDIAIE=1
+5 IF $GET(APCDVSIT)
IF $DATA(^AUPNVSIT(APCDVSIT))
Begin DoDot:1
+6 IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,7)="H"
IF $$DSCHDATE^APCLV(APCDVSIT)]""
SET APCDD=$$DSCHDATE^APCLV(APCDVSIT)
QUIT
+7 SET APCDD=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")
End DoDot:1
+8 IF APCDD=""
SET APCDD=$PIECE($GET(APCDDATE),".")
+9 IF APCDD=""
SET APCDD=DT
+10 SET APCDHDAT=APCDD
+11 ;
+12 SET APCDIMP=$$IMP^AUPNSICD(APCDD)
+13 SET APCDTFIE=".01"
SET APCDTDIA="POV"
SET APCDTDEL=""
SET APCDTNPV=""
+14 DO LEX
+15 IF $GET(APCDTDEL)
DO DELETE
+16 ;deleted the v pov
IF $GET(APCDTDEL)
QUIT
+17 ;"^" OUT
IF $GET(APCDTSKI)
QUIT
+18 IF $GET(APCDTNPV)=""
GOTO 2
+19 SET DIE="^AUPNVPOV("
SET DA=APCDTDA
SET DR=".01///"_APCDTNPV
DO ^DIE
KILL DIE,DA,DR
+20 IF $DATA(Y)
WRITE !?5,"??"
GOTO 1
2 ;DUAL CODING .24
+1 SET APCDIMP=$$IMP^AUPNSICD(APCDD)
+2 ;no dual for icd9 environment
IF APCDIMP=1
GOTO 3
+3 ;dual coding off
IF '$PIECE($GET(^APCDSITE(DUZ(2),0)),U,36)
GOTO 3
+4 DO K
+5 SET APCDTIN9=1
SET APCDTDIA="ICD-9 CODE"
SET APCDTDEL=""
SET APCDTNPV=""
SET APCDTFIE=".24"
SET APCDIMP=""
+6 SET APCDD=$$FMADD^XLFDT($$IMP^AUPNVUTL(30),-2)
SET APCDIMP=1
+7 DO LEX
+8 IF $GET(APCDTDEL)
DO DELETE
+9 IF $GET(APCDTDEL)
GOTO 3
+10 ;"^" OUT
IF $GET(APCDTSKI)
QUIT
+11 IF $GET(APCDTNPV)=""
GOTO 3
+12 KILL DIE,DA,DR
+13 SET DIE="^AUPNVPOV("
SET DA=APCDTDA
SET DR=".24///"_APCDTNPV
DO ^DIE
KILL DA,DR,DIE
+14 IF $DATA(Y)
WRITE !,"?? "
GOTO 2
3 ;
+1 ;W !!,"Please Note: '^'ing is not allowed with the remainder of this mnemonic."
+2 ;W !,"You must press enter through each field.",!
+3 ;PROVIDER NARRATIVE
+4 DO K
+5 IF $PIECE($GET(^AUPNVPOV(APCDTDA,11)),U,1)]""
Begin DoDot:1
+6 WRITE !!?5,"PROVIDER NARRATIVE: ",$$VAL^XBDIQ1(9000010.07,APCDTDA,.04),!!
End DoDot:1
GOTO 4
+7 IF $GET(APCDTTMP)="IPV"
Begin DoDot:1
+8 SET APCDTNQ=$EXTRACT($PIECE($$ICDDX^ICDEX($PIECE(^AUPNVPOV(APCDTDA,0),U,1),APCDD,,,"I"),U,4),1,140)_" ****ICD****"
+9 SET DA=APCDTDA
SET DIE="^AUPNVPOV("
SET DR=".04///"_APCDTNQ
SET DIE("NO^")=1
DO ^DIE
KILL DIE,DA,DR
+10 WRITE !!,"PROVIDER NARRATIVE: ",$$VAL^XBDIQ1(9000010.07,APCDTDA,.04)
End DoDot:1
GOTO 4
NA ;
+1 KILL DIR
SET DIR(0)="9000010.07,.04"
SET DIR("A")="PROVIDER NARRATIVE"
SET DIR("B")=$$VAL^XBDIQ1(9000010.07,APCDTDA,.04)
KILL DA
DO ^DIR
KILL DIR
+2 ;^
IF $DATA(DIRUT)
QUIT
+3 IF X["|"
DO EN^DDIOL("A vertical bar '|' is not allowed in the provider narrative")
GOTO NA
+4 SET APCDTNQ=+Y
+5 SET DA=APCDTDA
SET DIE="^AUPNVPOV("
SET DR=".04////"_APCDTNQ
DO ^DIE
KILL DIE,DA,DR
+6 ;S APCDTOLD=$$VAL^XBDIQ1(9000010.07,APCDTDA,.04)
+7 ;S APCDTNQ=$$GETNARR^APCDEA3($G(APCDTNQP),APCDTOLD)
+8 ;I APCDTNQ'=APCDTOLD S DA=APCDTDA,DIE="^AUPNVPOV(",DR=".04///"_APCDTNQ D ^DIE K DIE,DA,DR
4 ;PRESENT ON ADMISSION/PRIMARY/SECONDAY H VISITS ONLY
+1 DO K
+2 SET APCDTIMH=""
+3 SET DIE="^AUPNVPOV("
SET DA=APCDTDA
SET DR="[APCD EDIT POV]"
DO ^DIE
KILL DIE,DA,DR
+4 IF '$GET(APCDTIMH)
QUIT
89 ;
+1 DO K
+2 DO 8
+3 IF $GET(APCDTUPH)
QUIT
+4 DO 10
+5 IF $GET(APCDTUPH)
QUIT
+6 DO 12
+7 IF $GET(APCDTUPH)
QUIT
14 ;
+1 DO K
+2 DO POC
+3 IF $GET(APCDTUPH)
QUIT
17 ;
+1 SET DA=APCDTDA
SET DIE="^AUPNVPOV("
SET DR=".13;.08;1204"
DO ^DIE
KILL DIE,DA,DR
+2 QUIT
K ;
+1 KILL DIE,DA,DR,DIR
+2 KILL APCDTDEL,APCDTNPV,APCDTFIE,APCDTDIA,APCDIMP,APCDTIN9,APCDTUPH
+3 QUIT
8 ;EP -.09 CAUSE 1
+1 DO K
+2 KILL DIR
+3 SET APCDD=APCDHDAT
+4 ;
+5 SET APCDIMP=$$IMP^AUPNSICD(APCDD)
+6 SET APCDTFIE=".09"
SET APCDTDIA=$SELECT(APCDIMP=30:"CAUSE (V00-Y99 Code Range)",1:"CAUSE (E-Code)")
SET APCDTDEL=""
SET APCDTNPV=""
+7 DO CLEX^APCDCPOV
+8 IF $GET(APCDTDEL)
DO DELETE
+9 IF $GET(APCDTUPH)
QUIT
+10 IF $GET(APCDTNPV)=""
GOTO 9
+11 SET DIE="^AUPNVPOV("
SET DA=APCDTDA
SET DR=".09///"_APCDTNPV
DO ^DIE
KILL DIE,DA,DR
+12 IF $DATA(Y)
WRITE !?5,"??"
GOTO 8
9 ;DUAL CODE .25
+1 SET APCDIMP=$$IMP^AUPNSICD(APCDD)
+2 ;no dual for icd9 environment
IF APCDIMP=1
QUIT
+3 ;dual coding off
IF '$PIECE($GET(^APCDSITE(DUZ(2),0)),U,36)
QUIT
+4 DO K
+5 SET APCDTIN9=1
SET APCDTDIA="CAUSE (E-code)"
SET APCDTDEL=""
SET APCDTNPV=""
SET APCDTFIE=".25"
SET APCDIMP=""
+6 KILL APCDTUPH
+7 SET APCDD=$$FMADD^XLFDT($$IMP^AUPNVUTL(30),-2)
SET APCDIMP=1
+8 DO CLEX^APCDCPOV
+9 IF $GET(APCDTDEL)
DO DELETE
+10 IF $GET(APCDTUPH)
QUIT
+11 IF $GET(APCDTDEL)
QUIT
+12 IF $GET(APCDTNPV)=""
QUIT
+13 KILL DIE,DA,DR
+14 SET DIE="^AUPNVPOV("
SET DA=APCDTDA
SET DR=".25///"_APCDTNPV
DO ^DIE
KILL DA,DR,DIE
+15 IF $DATA(Y)
WRITE !,"?? "
GOTO 9
+16 QUIT
10 ;.18
+1 DO K
+2 KILL DIR
+3 SET APCDD=APCDHDAT
+4 ;
+5 SET APCDIMP=$$IMP^AUPNSICD(APCDD)
+6 SET APCDTFIE=".18"
SET APCDTDIA=$SELECT(APCDIMP=30:"CAUSE (V00-Y99 Code Range) #2",1:"CAUSE (E-Code) #2")
SET APCDTDEL=""
SET APCDTNPV=""
+7 KILL APCDTUPH
+8 DO CLEX^APCDCPOV
+9 IF $GET(APCDTDEL)
DO DELETE
+10 IF $GET(APCDTUPH)
QUIT
+11 IF $GET(APCDTNPV)=""
GOTO 11
+12 SET DIE="^AUPNVPOV("
SET DA=APCDTDA
SET DR=".18///"_APCDTNPV
DO ^DIE
KILL DIE,DA,DR
+13 IF $DATA(Y)
WRITE !?5,"??"
GOTO 10
11 ;DUAL CODE .26
+1 SET APCDIMP=$$IMP^AUPNSICD(APCDD)
+2 ;no dual for icd9 environment
IF APCDIMP=1
QUIT
+3 ;dual coding off
IF '$PIECE($GET(^APCDSITE(DUZ(2),0)),U,36)
QUIT
+4 DO K
+5 SET APCDTIN9=1
SET APCDTDIA="CAUSE (E-code) #2"
SET APCDTDEL=""
SET APCDTNPV=""
SET APCDTFIE=".26"
SET APCDIMP=""
+6 SET APCDD=$$FMADD^XLFDT($$IMP^AUPNVUTL(30),-2)
SET APCDIMP=1
+7 KILL APCDTUPH
+8 DO CLEX^APCDCPOV
+9 IF $GET(APCDTDEL)
DO DELETE
+10 IF $GET(APCDTDEL)
QUIT
+11 IF $GET(APCDTUPH)
QUIT
+12 IF $GET(APCDTNPV)=""
QUIT
+13 KILL DIE,DA,DR
+14 SET DIE="^AUPNVPOV("
SET DA=APCDTDA
SET DR=".26///"_APCDTNPV
DO ^DIE
KILL DA,DR,DIE
+15 IF $DATA(Y)
WRITE !,"?? "
GOTO 11
+16 QUIT
12 ;.19
+1 DO K
+2 KILL DIR
+3 SET APCDD=APCDHDAT
+4 ;
+5 SET APCDIMP=$$IMP^AUPNSICD(APCDD)
+6 SET APCDTFIE=".19"
SET APCDTDIA=$SELECT(APCDIMP=30:"CAUSE (V00-Y99 Code Range) #3",1:"CAUSE (E-Code) #3")
SET APCDTDEL=""
SET APCDTNPV=""
+7 KILL APCDTUPH
+8 DO CLEX^APCDCPOV
+9 IF $GET(APCDTDEL)
DO DELETE
+10 IF $GET(APCDTUPH)
QUIT
+11 IF $GET(APCDTNPV)=""
GOTO 13
+12 SET DIE="^AUPNVPOV("
SET DA=APCDTDA
SET DR=".19///"_APCDTNPV
DO ^DIE
KILL DIE,DA,DR
+13 IF $DATA(Y)
WRITE !?5,"??"
GOTO 12
13 ;DUAL CODE .27
+1 SET APCDIMP=$$IMP^AUPNSICD(APCDD)
+2 ;no dual for icd9 environment
IF APCDIMP=1
QUIT
+3 ;dual coding off
IF '$PIECE($GET(^APCDSITE(DUZ(2),0)),U,36)
QUIT
+4 DO K
+5 SET APCDTIN9=1
SET APCDTDIA="CAUSE (E-code) #3"
SET APCDTDEL=""
SET APCDTNPV=""
SET APCDTFIE=".27"
SET APCDIMP=""
+6 SET APCDD=$$FMADD^XLFDT($$IMP^AUPNVUTL(30),-2)
SET APCDIMP=1
+7 KILL APCDTUPH
+8 DO CLEX^APCDCPOV
+9 IF $GET(APCDTDEL)
DO DELETE
+10 IF $GET(APCDTDEL)
QUIT
+11 IF $GET(APCDTUPH)
QUIT
+12 IF $GET(APCDTNPV)=""
QUIT
+13 KILL DIE,DA,DR
+14 SET DIE="^AUPNVPOV("
SET DA=APCDTDA
SET DR=".26///"_APCDTNPV
DO ^DIE
KILL DA,DR,DIE
+15 IF $DATA(Y)
WRITE !,"?? "
GOTO 13
+16 QUIT
POC ;EP
141 ;RFB
+1 DO K
+2 KILL DIR,DIRUT
+3 SET APCDD=APCDHDAT
+4 ;
+5 SET APCDIMP=$$IMP^AUPNSICD(APCDD)
+6 ;NOT IN ICD9
IF APCDIMP=1
GOTO 15
+7 SET APCDTFIE=".23"
SET APCDTDIA="RETAINED FOREIGN BODY (Z18-Z18.9)"
SET APCDTDEL=""
SET APCDTNPV=""
+8 KILL APCDTUPH
+9 DO RLEX^APCDBPOV
+10 IF $GET(APCDTUPH)
QUIT
+11 IF $GET(APCDTDEL)
DO DELETE
+12 IF $GET(APCDTNPV)=""
GOTO 15
+13 SET DIE="^AUPNVPOV("
SET DA=APCDTDA
SET DR=".23///"_APCDTNPV
DO ^DIE
KILL DIE,DA,DR
+14 IF $DATA(Y)
WRITE !?5,"??"
GOTO 141
15 ;POC .21/.28
+1 DO K
+2 KILL DIR
+3 SET APCDD=APCDHDAT
+4 ;
+5 SET APCDIMP=$$IMP^AUPNSICD(APCDD)
+6 SET APCDTFIE=".21"
SET APCDTDIA=$SELECT(APCDIMP=30:"PLACE OF OCCURRENCE (Y92-Y92.9)",1:"PLACE OF OCCURRENCE (E849-E849.9)")
SET APCDTDEL=""
SET APCDTNPV=""
+7 KILL APCDTUPH
+8 DO PLEX^APCDLPOV
+9 IF $GET(APCDTUPH)
QUIT
+10 IF $GET(APCDTDEL)
DO DELETE
+11 IF $GET(APCDTNPV)=""
GOTO 16
+12 SET DIE="^AUPNVPOV("
SET DA=APCDTDA
SET DR=".21///"_APCDTNPV
DO ^DIE
KILL DIE,DA,DR
+13 IF $DATA(Y)
WRITE !?5,"??"
GOTO 15
16 ;DUAL CODE .28
+1 SET APCDIMP=$$IMP^AUPNSICD(APCDD)
+2 ;no dual for icd9 environment
IF APCDIMP=1
QUIT
+3 ;dual coding off
IF '$PIECE($GET(^APCDSITE(DUZ(2),0)),U,36)
QUIT
+4 DO K
+5 SET APCDTIN9=1
SET APCDTDIA="PLACE OF OCCURRENCE (E849-E849.9)"
SET APCDTDEL=""
SET APCDTNPV=""
SET APCDTFIE=".28"
SET APCDIMP=""
+6 SET APCDD=$$FMADD^XLFDT($$IMP^AUPNVUTL(30),-2)
SET APCDIMP=1
+7 KILL APCDTUPH
+8 DO PLEX^APCDLPOV
+9 IF $GET(APCDTUPH)
QUIT
+10 IF $GET(APCDTDEL)
DO DELETE
+11 IF $GET(APCDTDEL)
QUIT
+12 IF $GET(APCDTNPV)=""
QUIT
+13 KILL DIE,DA,DR
+14 SET DIE="^AUPNVPOV("
SET DA=APCDTDA
SET DR=".28///"_APCDTNPV
DO ^DIE
KILL DA,DR,DIE
+15 IF $DATA(Y)
WRITE !,"?? "
GOTO 16
+16 QUIT
LEX ;EP - called from input template
+1 ;reader call to get TEXT for code
+2 KILL DIR,APCDTDEL,DIRUT
+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("?")=$SELECT($GET(APCDTIN9):"^D HELP9^AUPNSIC9",1:"^D HELP^AUPNSICH")
+8 SET DIR("??")=$SELECT($GET(APCDTIN9):"^D HELP9^AUPNSIC9",1:"^D HELP^AUPNSICH")
+9 IF $$VAL^XBDIQ1(9000010.07,APCDTDA,APCDTFIE)]""
SET DIR("B")=$$VAL^XBDIQ1(9000010.07,APCDTDA,APCDTFIE)
+10 KILL DA
DO ^DIR
KILL DIR
+11 IF X="@"
SET APCDTDEL=1
GOTO XITL
+12 IF X=""
GOTO XITL
+13 IF $DATA(DIRUT)
SET APCDTSKI=1
GOTO XITL
+14 ;I Y="" G XITL
+15 SET APCDUINP=Y
+16 IF APCDUINP=$$VAL^XBDIQ1(9000010.07,APCDTDA,APCDTFIE)
GOTO XITL
+17 SET %=""
+18 IF APCDUINP=".9999"
SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"),,APCDIMP,"E")
GOTO LEXN
+19 IF APCDIMP=30
IF APCDUINP="ZZZ.999"
SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"))
GOTO LEXN
+20 IF APCDIMP=30
IF $EXTRACT(APCDUINP,1,4)="ZZZ."
SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"))
GOTO LEXN
+21 IF $EXTRACT(APCDUINP,1,7)="UNCODED"
SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"))
GOTO LEXN
+22 IF APCDUINP["UNCODED D"
SET %=+$$ICDDX^ICDEX($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"))
GOTO LEXN
+23 KILL ^TMP("LEXSCH",$JOB),^TMP("LEXHIT",$JOB),LEX,^TMP("LEXFND",$JOB)
+24 IF APCDIMP=1
DO CONFIG^LEXSET("ICD","ICD",$PIECE(APCDD,"."))
+25 IF APCDIMP=30
DO CONFIG^LEXSET("10D","10D",$PIECE(APCDD,"."))
+26 SET X=APCDUINP
+27 IF APCDIMP=1
SET DIC("S")=$SELECT('$GET(APCDTIN9):"I $$ICDONE9^APCDAPOV(+Y,LEXVDT)",1:"I $$ICDONE99^APCDAPOV(+Y,LEXVDT)")
+28 IF APCDIMP=30
SET DIC("S")="I $$ICDONE1^APCDAPOV(+Y,LEXVDT)"
+29 SET DIC("A")=$SELECT($GET(APCDTDIA)]"":APCDTDIA_": ",1:"Enter PURPOSE OF VISIT: ")
+30 IF APCDIMP=1
DO LOOK^LEXA(X,"ICD",999,"ICD",$PIECE(APCDD,"."))
+31 IF APCDIMP=30
DO LOOK^LEXA(X,"10D",999,"10D",$PIECE(APCDD,"."))
+32 IF 'LEX
Begin DoDot:1
+33 SET X=0
FOR
SET X=$ORDER(LEX("HLP",X))
IF X'=+X
QUIT
WRITE !,LEX("HLP",X)
+34 ;now check fileman V2.0 PATCH 20 CR#554
+35 WRITE !!,"now trying secondary fileman lookup..."
+36 SET %=""
SET X=APCDUINP
SET DIC="^ICD9("
SET DIC(0)="MEQ"
SET DIC("S")="D ^AUPNSICD"
DO ^DIC
KILL DIC
+37 SET %=""
IF $PIECE(Y,U)'=-1
SET %=+Y
End DoDot:1
IF %=""
GOTO LEX
IF %
GOTO LEXN
+38 ;display all codes and call reader
+39 SET APCDANS=""
+40 DO GETANS^APCDAPOV
+41 IF APCDY="^"
WRITE !
Begin DoDot:1
+42 ;now check fileman
+43 ;W !!,"now trying fileman lookup..."
+44 ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="QME" D ^DIC K DIC
SET %=""
+45 ;S %="" I $P(Y,U)'=-1 S %=+Y
End DoDot:1
IF %=""
GOTO LEX
IF %
GOTO LEXN
+46 IF APCDY=""
WRITE !
Begin DoDot:1
+47 ;now check fileman
+48 ;W !!,"now trying fileman lookup..."
+49 ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="MEQ" D ^DIC K DIC
SET %=""
+50 ;S %="" I $P(Y,U)'=-1 S %=+Y
End DoDot:1
IF %=""
GOTO LEX
IF %
GOTO LEXN
+51 IF '$GET(APCDY)
WRITE !
Begin DoDot:1
+52 ;now check fileman
+53 ;W !!,"now trying fileman lookup..."
+54 ;S X=APCDUINP,DIC="^ICD9(",DIC(0)="MEQ" D ^DIC K DIC
SET %=""
+55 ;S %="" I $P(Y,U)'=-1 S %=+Y
End DoDot:1
IF %=""
GOTO LEX
IF %
GOTO LEXN
+56 IF APCDIMP=1
SET Y=$$ICDONE^LEXU($PIECE(^TMP("LEXHIT",$JOB,APCDY),U,1),$PIECE(APCDD,"."))
+57 IF APCDIMP=30
SET Y=$$ONE^LEXU($PIECE(^TMP("LEXHIT",$JOB,APCDY),U,1),$PIECE(APCDD,"."),"10D")
+58 KILL DO,^TMP("LEXSCH",$JOB)
+59 IF $GET(Y)=""
WRITE !!,"lexicon isn't passing back an ICD code."
SET APCDTERR=1
SET APCDTNPV=""
GOTO XITL
+60 SET %=$$ICDDX^ICDEX(Y,$PIECE(APCDD,"."),,"E")
+61 IF $PIECE(%,U,1)="-1"
WRITE !!,"lexicon isn't passing back an ICD code."
SET APCDTERR=1
SET APCDTNPV=""
GOTO XITL
LEXN ;
+1 SET APCDTNPV="`"_+%
SET APCDTNQP=APCDUINP
+2 WRITE !
XITL KILL Y,X,DO,D,DD,DIPGM,APCDTPCC
+1 QUIT
DELETE ;
+1 SET APCDTDEL=0
+2 IF APCDTFIE=".01"
Begin DoDot:1
+3 KILL DIR
+4 SET DIR(0)="Y"
SET DIR("A")=" SURE YOU WANT TO DELETE THE ENTIRE V POV"
KILL DA
DO ^DIR
KILL DIR
+5 IF 'Y
QUIT
+6 IF $DATA(DIRUT)
QUIT
+7 SET APCDTDEL=1
+8 SET DA=APCDTDA
SET DIK="^AUPNVPOV("
DO ^DIK
End DoDot:1
QUIT
+9 KILL DIR
+10 SET DIR(0)="Y"
SET DIR("A")=" SURE YOU WANT TO DELETE"
KILL DA
DO ^DIR
KILL DIR
+11 IF 'Y
QUIT
+12 IF $DATA(DIRUT)
QUIT
+13 SET DA=APCDTDA
SET DIE="^AUPNVPOV("
SET DR=APCDTFIE_"///@"
DO ^DIE
KILL DIE,DA,DR
+14 QUIT
ECOD ;
+1 ;EP
+2 DO EN^XBNEW("ECOD1^APCDEPOV","APCDTDA;APCDVSIT;APCDPAT;APCDDATE;DFN;AUPNPAT;AUPNVSIT;APCDTTMP")
+3 QUIT
ECOD1 ;
+1 WRITE !
+2 KILL DIR
+3 SET APCDD=""
+4 IF $GET(APCDVSIT)
IF $DATA(^AUPNVSIT(APCDVSIT))
Begin DoDot:1
+5 IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,7)="H"
IF $$DSCHDATE^APCLV(APCDVSIT)]""
SET APCDD=$$DSCHDATE^APCLV(APCDVSIT)
QUIT
+6 SET APCDD=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")
End DoDot:1
+7 IF APCDD=""
SET APCDD=$PIECE($GET(APCDDATE),".")
+8 IF APCDD=""
SET APCDD=DT
+9 SET APCDHDAT=APCDD
+10 ;
+11 SET APCDIMP=$$IMP^AUPNSICD(APCDD)
+12 DO 8
+13 DO POC
+14 QUIT
ECO2 ;
+1 ;EP
+2 DO EN^XBNEW("ECO21^APCDEPOV","APCDTDA;APCDVSIT;APCDPAT;APCDDATE;DFN;AUPNPAT;AUPNVSIT;APCDTTMP")
+3 QUIT
ECO21 ;
+1 WRITE !
+2 KILL DIR
+3 SET APCDD=""
+4 IF $GET(APCDVSIT)
IF $DATA(^AUPNVSIT(APCDVSIT))
Begin DoDot:1
+5 IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,7)="H"
IF $$DSCHDATE^APCLV(APCDVSIT)]""
SET APCDD=$$DSCHDATE^APCLV(APCDVSIT)
QUIT
+6 SET APCDD=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")
End DoDot:1
+7 IF APCDD=""
SET APCDD=$PIECE($GET(APCDDATE),".")
+8 IF APCDD=""
SET APCDD=DT
+9 SET APCDHDAT=APCDD
+10 ;
+11 SET APCDIMP=$$IMP^AUPNSICD(APCDD)
+12 DO 10
+13 QUIT
ECO3 ;
+1 ;EP
+2 DO EN^XBNEW("ECO31^APCDEPOV","APCDTDA;APCDVSIT;APCDPAT;APCDDATE;DFN;AUPNPAT;AUPNVSIT;APCDTTMP")
+3 QUIT
ECO31 ;
+1 WRITE !
+2 KILL DIR
+3 SET APCDD=""
+4 IF $GET(APCDVSIT)
IF $DATA(^AUPNVSIT(APCDVSIT))
Begin DoDot:1
+5 IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,7)="H"
IF $$DSCHDATE^APCLV(APCDVSIT)]""
SET APCDD=$$DSCHDATE^APCLV(APCDVSIT)
QUIT
+6 SET APCDD=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")
End DoDot:1
+7 IF APCDD=""
SET APCDD=$PIECE($GET(APCDDATE),".")
+8 IF APCDD=""
SET APCDD=DT
+9 SET APCDHDAT=APCDD
+10 ;
+11 SET APCDIMP=$$IMP^AUPNSICD(APCDD)
+12 DO 12
+13 QUIT
