APCDFUNC ; IHS/CMI/LAB - FIX UNCODED DX ;
;;2.0;IHS PCC SUITE;**2,10,11**;MAY 14, 2009;Build 58
;
POV ;EP
S APCDFILE=9000010.07,APCDTEMP="[APCD FUD POV]" D GETCODE,GETDATE G:$G(APCDQUIT) XIT G PROCESS
;
PROB ;EP
;
S APCDFILE=9000011,APCDTEMP="[APCD FUD PROB]" D GETCODE,GETDATE G:$G(APCDQUIT) XIT G PROCESS
FAMILY ;EP
S APCDFILE=9000014,APCDTEMP="[APCD FUD FAMHX]" D GETCODE,GETDATE G:$G(APCDQUIT) XIT G PROCESS
;
PERS ;EP
S APCDFILE=9000013,APCDTEMP="[APCD FUD PER HX]" D GETCODE,GETDATE G:$G(APCDQUIT) XIT G PROCESS
;
PRO ;EP
S APCDFILE=9000010.08,APCDTEMP="[APCD FUD PROC]"
D GETDATE I $D(APCDQUIT) D XIT Q
S APCD999=$P($$ICDOP^ICDEX(".9999",,2,"E"),U),APCD990=$P($$ICDOP^ICDEX("ZZZ999",,31,"E"),U) G PROCESS
;
Q
GETDATE ;get beginning date ; -- add to code for a date range
W !!,"The search for Uncoded "_$P(^DIC(APCDFILE,0),U),"'s can begin at any date",!,"that you specify. To get all of the uncoded entries enter a really early "
W !,"date like 01/01/1930. If you want to only review data for visits ",!,"in the past week, enter T-7.",!
S APCDFUDT=""
S DIR(0)="D^::EP",DIR("A")="Enter the Beginning Date to Search for Uncoded "_$P(^DIC(APCDFILE,0),U)_"'s" KILL DA D ^DIR KILL DIR
I $D(DIRUT) S APCDQUIT=1 Q
S APCDFUDT=Y
LOC ;
S APCDLOCT=""
S DIR(0)="S^A:ALL Locations/Facilities;S:One SERVICE UNIT'S Locations/Facilities;O:ONE Location/Facility",DIR("A")="Include Visits to Which Location/Facilities",DIR("B")="A"
S DIR("A")="Enter a code indicating what LOCATIONS/FACILITIES are of interest",DIR("B")="O" K DA D ^DIR K DIR,DA
G:$D(DIRUT) GETDATE
S APCDLOCT=Y
I APCDLOCT="A" Q
D @APCDLOCT
G:$D(APCDQUIT) LOC
Q
CHKDATE ;
S APCDOK=0
S APCDG=APCDVDG_"APCDDFN,0)" S Y=$P(@APCDG,U,2),APCDVSIT=$P(@APCDG,U,3) I Y=""!(APCDVSIT="") W !,"ERROR IN GLOBAL -- NOTIFY PROGRAMMER - PATIENT OR VISIT DFN MISSING" Q
I $L(APCDFILE)>7 Q:'$D(^AUPNVSIT(APCDVSIT)) I $P($P(^AUPNVSIT(APCDVSIT,0),U),".")<APCDFUDT Q ;before date wanted
I $L(APCDFILE)=7,$P(@APCDG,U,3)<APCDFUDT Q ;quit if problem modified before date
S APCDOK=1
Q
CHKLOC ;
I APCDFILE=9000011 D Q
.S APCDOK=0
.I $P(^AUPNPROB(APCDDFN,0),U,12)="D" Q ;DELETED STATUS
.Q:$P($G(^AUPNPROB(APCDDFN,800)),U,1)]""
.I APCDLOCT="O",$P(^AUPNPROB(APCDDFN,0),U,6)'=APCDLOCT("ONE") Q
.I APCDLOCT="S",$$VALI^XBDIQ1(9999999.06,$P(^AUPNPROB(APCDDFN,0),U,6),.05)'=APCDLOCT("SU") Q
.S APCDOK=1
I $L(APCDFILE)=7 S APCDOK=1 Q
S APCDOK=0
I APCDLOCT="O",$P(^AUPNVSIT(APCDVSIT,0),U,6)'=APCDLOCT("ONE") Q
I APCDLOCT="S",$$VALI^XBDIQ1(9999999.06,$P(^AUPNVSIT(APCDVSIT,0),U,6),.05)'=APCDLOCT("SU") Q
S APCDOK=1
Q
GETCODE ;
K APCDQUIT ;IHS/CMI/LAB
D SETDEF Q
SETDEF ;SET DEFAULT OF .9999
S APCD999=$P($$ICDDX^ICDEX(".9999",,1,"E"),U,1)
S APCD990=$P($$ICDDX^ICDEX("ZZZ.999",,30,"E"),U,1)
Q
O ;one community
S DIC="^AUTTLOC(",DIC(0)="AEMQ",DIC("A")="Which LOCATION: " D ^DIC K DIC
I Y=-1 S APCDQUIT="" Q
S APCDLOCT("ONE")=+Y
Q
S ;all communities within APCDSU su
S DIC="^AUTTSU(",DIC("B")=$$VAL^XBDIQ1(9999999.06,DUZ(2),.05),DIC(0)="AEMQ",DIC("A")="Which SERVICE UNIT: " D ^DIC K DIC
I Y=-1 S APCDQUIT="" Q
S APCDLOCT("SU")=+Y
Q
;
XIT ;
K APCDFILE,APCDDFN,APCDVDG,APCDVIGR,APCDCONT,APCDTEMP,APCD999,APCD990,APCDG,APCDL,APCDHRN,APCDDOB,APCDVSIT,AUPNSEX,AUPNPAT,AUPNDOB,AUPNDAYS,APCDEIN,AUPNDOD,APCDCAT,APCDFUDT,APCDOK,APCDQUIT ;IHS/CMI/LAB - added APCDQUIT
Q
PROCESS ;
I APCD999="" W !!,"ERROR -- .9999 NOT IN ICD ",$S(APCDFILE=9000010.08:"PROCEDURE",1:"DIAGNOSIS")," FILE, NOTIFY YOUR SUPERVISOR" G XIT
I APCD990="" W !!,"ERROR -- ",$S(APCFILE=9000010.08:"ZZZ999",1:"ZZZ.999")," NOT IN ICD ",$S(APCDFILE=9000010.08:"PROCEDURE",1:"DIAGNOSIS")," FILE, NOTIFY YOUR SUPERVISOR" G XIT
S APCDEIN="",APCDDFN="",U="^"
I '$D(^DIC(APCDFILE)) W !!,"FILE DOES NOT EXIST -- NOTIFY YOUR SUPERVISOR" G XIT
S APCDVDG=$P(^DIC(APCDFILE,0),U) I APCDVDG="" W !,"ERROR IN ^DIC -- NOTIFY PROGRAMMER" G XIT
S APCDVDG=^DIC(APCDFILE,0,"GL")
S APCDG=APCDVDG_"""B"",APCD999)"
S APCDG0=APCDVDG_"""B"",APCD990)"
I '$D(@APCDG),'$D(APCDG0) W !!,"There are no Uncoded codes to change." Q
S APCDVIGR=APCDVDG_"""B"",APCD999,APCDDFN)"
W !!,"Searching the ",$P(^DIC(APCDFILE,0),U)," File",!
S APCDDFN=0,APCDCONT=1 F APCDL=0:0 S APCDDFN=$O(@APCDVIGR) Q:APCDDFN'=+APCDDFN D CHKDATE I APCDOK D CHKLOC I APCDOK D CONT Q:'APCDCONT D APCDDIE
S APCDVIGR=APCDVDG_"""B"",APCD990,APCDDFN)"
S APCDDFN=0,APCDCONT=1 F APCDL=0:0 S APCDDFN=$O(@APCDVIGR) Q:APCDDFN'=+APCDDFN D CHKDATE I APCDOK D CHKLOC I APCDOK D CONT Q:'APCDCONT D APCDDIE
W !!,"All done with the ",$P(^DIC(APCDFILE,0),U)," file",!
D XIT
Q
CONT ;
W !!
S DIR("A")="Continue",DIR("B")="Y",DIR(0)="Y" D ^DIR
I $D(DIRUT) S X="N"
S:"Nn"[X APCDCONT=""
W !
K DIR,DIRUT,DUOUT,DTOUT,DIROUT
Q
APCDDIE ;
S APCDG=APCDVDG_"APCDDFN,0)" S Y=$P(@APCDG,U,2),APCDVSIT=$P(@APCDG,U,3) I Y=""!(APCDVSIT="") W !,"ERROR IN GLOBAL -- NOTIFY PROGRAMMER - PATIENT OR VISIT DFN MISSING" Q
D ^AUPNPAT
I $L(APCDFILE)>7,AUPNDOB]"" S X2=AUPNDOB,X1=$P(^AUPNVSIT(APCDVSIT,0),U)\1 D ^%DTC S AUPNDAYS=X ; re-set days of age to visit date-dob
S Y=AUPNDOB X ^DD("DD") S APCDDOB=Y
S APCDHRN="" I $D(^AUPNPAT(AUPNPAT,41,DUZ(2),0)) S APCDHRN=$P(^AUPNPAT(AUPNPAT,41,DUZ(2),0),U,2)
W !,"NAME: ",$P(^DPT(AUPNPAT,0),U)," DOB: ",APCDDOB," SEX: ",AUPNSEX," HRN: ",$S(APCDHRN]"":APCDHRN,1:"NONE")
I $L(APCDFILE)>7 S APCDCAT=$P(^AUPNVSIT(APCDVSIT,0),U,7) W !,"DATE OF VISIT: " S Y=$P(^AUPNVSIT(APCDVSIT,0),U) D DT^DIO2 S Y="" W " LOC: ",$P(^DIC(4,$P(^AUPNVSIT(APCDVSIT,0),U,6),0),U)
S DA=APCDDFN,DIC=APCDVDG D EN^DIQ
I APCDFILE=9000010.07,$$VAL^XBDIQ1(APCDFILE,APCDDFN,1101)]"" NEW APCDLOOK S APCDLOOK=APCDDFN D EN^XBNEW("MAP^APCDFUNC","APCDLOOK")
S DA=APCDDFN,DIE=APCDVDG,DR=APCDTEMP D ^DIE K DA,DIE,DR
I $L(APCDFILE)>7 S AUPNVSIT=APCDVSIT D MOD^AUPNVSIT
Q
DOC ;
; need to change to go thru PT node of ICD9 and
; fix all files in the 9000001-9000099 range.
;
MAP ;EP - CALLED FROM XBDBQUE
S D=$$VD^APCLV($P(^AUPNVPOV(APCDLOOK,0),U,3))
S D=$$IMP^AUPNSICD(D)
I D'=30 Q ;ICD10 ONLY
S C=$$VAL^XBDIQ1(9000010.07,APCDLOOK,1101)
;GET MAP ADVICE
S D=$$I10ADV^BSTSAPI("APCDV",C)
I 'D Q ;NO MAP ADVICE
;ASK TO DISPLAY
W !!,"This POV has been SNOMED coded and there is map advice available."
K DIR
S DIR(0)="Y",DIR("A")="Do you wish to see the Map Advice",DIR("B")="Y" KILL DA
D ^DIR KILL DIR
I $D(DIRUT) Q
I 'Y Q
;ZW APCDV
S X=0 F S X=$O(APCDV(X)) Q:X'=+X S APCDJ(X,0)=APCDV(X)
K APCDV
D ARRAY^XBLM("APCDJ(","Map Advice for SNOMED Concept ID: "_C)
;REDISPLAY POV
S DA=APCDLOOK,DIC="^AUPNVPOV(" D EN^DIQ
Q
APCDFUNC ; IHS/CMI/LAB - FIX UNCODED DX ;
+1 ;;2.0;IHS PCC SUITE;**2,10,11**;MAY 14, 2009;Build 58
+2 ;
POV ;EP
+1 SET APCDFILE=9000010.07
SET APCDTEMP="[APCD FUD POV]"
DO GETCODE
DO GETDATE
IF $GET(APCDQUIT)
GOTO XIT
GOTO PROCESS
+2 ;
PROB ;EP
+1 ;
+2 SET APCDFILE=9000011
SET APCDTEMP="[APCD FUD PROB]"
DO GETCODE
DO GETDATE
IF $GET(APCDQUIT)
GOTO XIT
GOTO PROCESS
FAMILY ;EP
+1 SET APCDFILE=9000014
SET APCDTEMP="[APCD FUD FAMHX]"
DO GETCODE
DO GETDATE
IF $GET(APCDQUIT)
GOTO XIT
GOTO PROCESS
+2 ;
PERS ;EP
+1 SET APCDFILE=9000013
SET APCDTEMP="[APCD FUD PER HX]"
DO GETCODE
DO GETDATE
IF $GET(APCDQUIT)
GOTO XIT
GOTO PROCESS
+2 ;
PRO ;EP
+1 SET APCDFILE=9000010.08
SET APCDTEMP="[APCD FUD PROC]"
+2 DO GETDATE
IF $DATA(APCDQUIT)
DO XIT
QUIT
+3 SET APCD999=$PIECE($$ICDOP^ICDEX(".9999",,2,"E"),U)
SET APCD990=$PIECE($$ICDOP^ICDEX("ZZZ999",,31,"E"),U)
GOTO PROCESS
+4 ;
+5 QUIT
GETDATE ;get beginning date ; -- add to code for a date range
+1 WRITE !!,"The search for Uncoded "_$PIECE(^DIC(APCDFILE,0),U),"'s can begin at any date",!,"that you specify. To get all of the uncoded entries enter a really early "
+2 WRITE !,"date like 01/01/1930. If you want to only review data for visits ",!,"in the past week, enter T-7.",!
+3 SET APCDFUDT=""
+4 SET DIR(0)="D^::EP"
SET DIR("A")="Enter the Beginning Date to Search for Uncoded "_$PIECE(^DIC(APCDFILE,0),U)_"'s"
KILL DA
DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
SET APCDQUIT=1
QUIT
+6 SET APCDFUDT=Y
LOC ;
+1 SET APCDLOCT=""
+2 SET DIR(0)="S^A:ALL Locations/Facilities;S:One SERVICE UNIT'S Locations/Facilities;O:ONE Location/Facility"
SET DIR("A")="Include Visits to Which Location/Facilities"
SET DIR("B")="A"
+3 SET DIR("A")="Enter a code indicating what LOCATIONS/FACILITIES are of interest"
SET DIR("B")="O"
KILL DA
DO ^DIR
KILL DIR,DA
+4 IF $DATA(DIRUT)
GOTO GETDATE
+5 SET APCDLOCT=Y
+6 IF APCDLOCT="A"
QUIT
+7 DO @APCDLOCT
+8 IF $DATA(APCDQUIT)
GOTO LOC
+9 QUIT
CHKDATE ;
+1 SET APCDOK=0
+2 SET APCDG=APCDVDG_"APCDDFN,0)"
SET Y=$PIECE(@APCDG,U,2)
SET APCDVSIT=$PIECE(@APCDG,U,3)
IF Y=""!(APCDVSIT="")
WRITE !,"ERROR IN GLOBAL -- NOTIFY PROGRAMMER - PATIENT OR VISIT DFN MISSING"
QUIT
+3 ;before date wanted
IF $LENGTH(APCDFILE)>7
IF '$DATA(^AUPNVSIT(APCDVSIT))
QUIT
IF $PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")<APCDFUDT
QUIT
+4 ;quit if problem modified before date
IF $LENGTH(APCDFILE)=7
IF $PIECE(@APCDG,U,3)<APCDFUDT
QUIT
+5 SET APCDOK=1
+6 QUIT
CHKLOC ;
+1 IF APCDFILE=9000011
Begin DoDot:1
+2 SET APCDOK=0
+3 ;DELETED STATUS
IF $PIECE(^AUPNPROB(APCDDFN,0),U,12)="D"
QUIT
+4 IF $PIECE($GET(^AUPNPROB(APCDDFN,800)),U,1)]""
QUIT
+5 IF APCDLOCT="O"
IF $PIECE(^AUPNPROB(APCDDFN,0),U,6)'=APCDLOCT("ONE")
QUIT
+6 IF APCDLOCT="S"
IF $$VALI^XBDIQ1(9999999.06,$PIECE(^AUPNPROB(APCDDFN,0),U,6),.05)'=APCDLOCT("SU")
QUIT
+7 SET APCDOK=1
End DoDot:1
QUIT
+8 IF $LENGTH(APCDFILE)=7
SET APCDOK=1
QUIT
+9 SET APCDOK=0
+10 IF APCDLOCT="O"
IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,6)'=APCDLOCT("ONE")
QUIT
+11 IF APCDLOCT="S"
IF $$VALI^XBDIQ1(9999999.06,$PIECE(^AUPNVSIT(APCDVSIT,0),U,6),.05)'=APCDLOCT("SU")
QUIT
+12 SET APCDOK=1
+13 QUIT
GETCODE ;
+1 ;IHS/CMI/LAB
KILL APCDQUIT
+2 DO SETDEF
QUIT
SETDEF ;SET DEFAULT OF .9999
+1 SET APCD999=$PIECE($$ICDDX^ICDEX(".9999",,1,"E"),U,1)
+2 SET APCD990=$PIECE($$ICDDX^ICDEX("ZZZ.999",,30,"E"),U,1)
+3 QUIT
O ;one community
+1 SET DIC="^AUTTLOC("
SET DIC(0)="AEMQ"
SET DIC("A")="Which LOCATION: "
DO ^DIC
KILL DIC
+2 IF Y=-1
SET APCDQUIT=""
QUIT
+3 SET APCDLOCT("ONE")=+Y
+4 QUIT
S ;all communities within APCDSU su
+1 SET DIC="^AUTTSU("
SET DIC("B")=$$VAL^XBDIQ1(9999999.06,DUZ(2),.05)
SET DIC(0)="AEMQ"
SET DIC("A")="Which SERVICE UNIT: "
DO ^DIC
KILL DIC
+2 IF Y=-1
SET APCDQUIT=""
QUIT
+3 SET APCDLOCT("SU")=+Y
+4 QUIT
+5 ;
XIT ;
+1 ;IHS/CMI/LAB - added APCDQUIT
KILL APCDFILE,APCDDFN,APCDVDG,APCDVIGR,APCDCONT,APCDTEMP,APCD999,APCD990,APCDG,APCDL,APCDHRN,APCDDOB,APCDVSIT,AUPNSEX,AUPNPAT,AUPNDOB,AUPNDAYS,APCDEIN,AUPNDOD,APCDCAT,APCDFUDT,APCDOK,APCDQUIT
+2 QUIT
PROCESS ;
+1 IF APCD999=""
WRITE !!,"ERROR -- .9999 NOT IN ICD ",$SELECT(APCDFILE=9000010.08:"PROCEDURE",1:"DIAGNOSIS")," FILE, NOTIFY YOUR SUPERVISOR"
GOTO XIT
+2 IF APCD990=""
WRITE !!,"ERROR -- ",$SELECT(APCFILE=9000010.08:"ZZZ999",1:"ZZZ.999")," NOT IN ICD ",$SELECT(APCDFILE=9000010.08:"PROCEDURE",1:"DIAGNOSIS")," FILE, NOTIFY YOUR SUPERVISOR"
GOTO XIT
+3 SET APCDEIN=""
SET APCDDFN=""
SET U="^"
+4 IF '$DATA(^DIC(APCDFILE))
WRITE !!,"FILE DOES NOT EXIST -- NOTIFY YOUR SUPERVISOR"
GOTO XIT
+5 SET APCDVDG=$PIECE(^DIC(APCDFILE,0),U)
IF APCDVDG=""
WRITE !,"ERROR IN ^DIC -- NOTIFY PROGRAMMER"
GOTO XIT
+6 SET APCDVDG=^DIC(APCDFILE,0,"GL")
+7 SET APCDG=APCDVDG_"""B"",APCD999)"
+8 SET APCDG0=APCDVDG_"""B"",APCD990)"
+9 IF '$DATA(@APCDG)
IF '$DATA(APCDG0)
WRITE !!,"There are no Uncoded codes to change."
QUIT
+10 SET APCDVIGR=APCDVDG_"""B"",APCD999,APCDDFN)"
+11 WRITE !!,"Searching the ",$PIECE(^DIC(APCDFILE,0),U)," File",!
+12 SET APCDDFN=0
SET APCDCONT=1
FOR APCDL=0:0
SET APCDDFN=$ORDER(@APCDVIGR)
IF APCDDFN'=+APCDDFN
QUIT
DO CHKDATE
IF APCDOK
DO CHKLOC
IF APCDOK
DO CONT
IF 'APCDCONT
QUIT
DO APCDDIE
+13 SET APCDVIGR=APCDVDG_"""B"",APCD990,APCDDFN)"
+14 SET APCDDFN=0
SET APCDCONT=1
FOR APCDL=0:0
SET APCDDFN=$ORDER(@APCDVIGR)
IF APCDDFN'=+APCDDFN
QUIT
DO CHKDATE
IF APCDOK
DO CHKLOC
IF APCDOK
DO CONT
IF 'APCDCONT
QUIT
DO APCDDIE
+15 WRITE !!,"All done with the ",$PIECE(^DIC(APCDFILE,0),U)," file",!
+16 DO XIT
+17 QUIT
CONT ;
+1 WRITE !!
+2 SET DIR("A")="Continue"
SET DIR("B")="Y"
SET DIR(0)="Y"
DO ^DIR
+3 IF $DATA(DIRUT)
SET X="N"
+4 IF "Nn"[X
SET APCDCONT=""
+5 WRITE !
+6 KILL DIR,DIRUT,DUOUT,DTOUT,DIROUT
+7 QUIT
APCDDIE ;
+1 SET APCDG=APCDVDG_"APCDDFN,0)"
SET Y=$PIECE(@APCDG,U,2)
SET APCDVSIT=$PIECE(@APCDG,U,3)
IF Y=""!(APCDVSIT="")
WRITE !,"ERROR IN GLOBAL -- NOTIFY PROGRAMMER - PATIENT OR VISIT DFN MISSING"
QUIT
+2 DO ^AUPNPAT
+3 ; re-set days of age to visit date-dob
IF $LENGTH(APCDFILE)>7
IF AUPNDOB]""
SET X2=AUPNDOB
SET X1=$PIECE(^AUPNVSIT(APCDVSIT,0),U)\1
DO ^%DTC
SET AUPNDAYS=X
+4 SET Y=AUPNDOB
XECUTE ^DD("DD")
SET APCDDOB=Y
+5 SET APCDHRN=""
IF $DATA(^AUPNPAT(AUPNPAT,41,DUZ(2),0))
SET APCDHRN=$PIECE(^AUPNPAT(AUPNPAT,41,DUZ(2),0),U,2)
+6 WRITE !,"NAME: ",$PIECE(^DPT(AUPNPAT,0),U)," DOB: ",APCDDOB," SEX: ",AUPNSEX," HRN: ",$SELECT(APCDHRN]"":APCDHRN,1:"NONE")
+7 IF $LENGTH(APCDFILE)>7
SET APCDCAT=$PIECE(^AUPNVSIT(APCDVSIT,0),U,7)
WRITE !,"DATE OF VISIT: "
SET Y=$PIECE(^AUPNVSIT(APCDVSIT,0),U)
DO DT^DIO2
SET Y=""
WRITE " LOC: ",$PIECE(^DIC(4,$PIECE(^AUPNVSIT(APCDVSIT,0),U,6),0),U)
+8 SET DA=APCDDFN
SET DIC=APCDVDG
DO EN^DIQ
+9 IF APCDFILE=9000010.07
IF $$VAL^XBDIQ1(APCDFILE,APCDDFN,1101)]""
NEW APCDLOOK
SET APCDLOOK=APCDDFN
DO EN^XBNEW("MAP^APCDFUNC","APCDLOOK")
+10 SET DA=APCDDFN
SET DIE=APCDVDG
SET DR=APCDTEMP
DO ^DIE
KILL DA,DIE,DR
+11 IF $LENGTH(APCDFILE)>7
SET AUPNVSIT=APCDVSIT
DO MOD^AUPNVSIT
+12 QUIT
DOC ;
+1 ; need to change to go thru PT node of ICD9 and
+2 ; fix all files in the 9000001-9000099 range.
+3 ;
MAP ;EP - CALLED FROM XBDBQUE
+1 SET D=$$VD^APCLV($PIECE(^AUPNVPOV(APCDLOOK,0),U,3))
+2 SET D=$$IMP^AUPNSICD(D)
+3 ;ICD10 ONLY
IF D'=30
QUIT
+4 SET C=$$VAL^XBDIQ1(9000010.07,APCDLOOK,1101)
+5 ;GET MAP ADVICE
+6 SET D=$$I10ADV^BSTSAPI("APCDV",C)
+7 ;NO MAP ADVICE
IF 'D
QUIT
+8 ;ASK TO DISPLAY
+9 WRITE !!,"This POV has been SNOMED coded and there is map advice available."
+10 KILL DIR
+11 SET DIR(0)="Y"
SET DIR("A")="Do you wish to see the Map Advice"
SET DIR("B")="Y"
KILL DA
+12 DO ^DIR
KILL DIR
+13 IF $DATA(DIRUT)
QUIT
+14 IF 'Y
QUIT
+15 ;ZW APCDV
+16 SET X=0
FOR
SET X=$ORDER(APCDV(X))
IF X'=+X
QUIT
SET APCDJ(X,0)=APCDV(X)
+17 KILL APCDV
+18 DO ARRAY^XBLM("APCDJ(","Map Advice for SNOMED Concept ID: "_C)
+19 ;REDISPLAY POV
+20 SET DA=APCDLOOK
SET DIC="^AUPNVPOV("
DO EN^DIQ
+21 QUIT
