- 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
