APCDSW ; IHS/CMI/LAB - SWITCH TO V FILE ;
;;2.0;IHS PCC SUITE;**5,11,15,22**;MAY 14, 2009;Build 6
;
; APCDSWD=DICTIONARY NUMBER
; APCDSWCR=LINKING CROSS REFERENCE
; APCDSWV=VISIT DFN
;
I $G(APCDVFIE)>0 S APCDLOOK=APCDVFIE Q
S U="^"
S APCDLOOK=""
Q:'$D(APCDSWV)
Q:APCDSWV=""
Q:'$D(APCDSWD)
Q:'APCDSWD
Q:'$D(^DIC(APCDSWD,0,"GL"))
S APCDSWG=^DIC(APCDSWD,0,"GL")
I '$D(APCDSWCR),APCDSWD'=(APCDSWD\1),APCDSWD\1=9000010 S APCDSWCR="AD"
I '$D(APCDSWCR),APCDSWD\1'=9000010 S APCDSWCR="AC"
Q:'$D(APCDSWCR)
Q:APCDSWCR=""
W !
S APCDSWDA=0 F APCDSWI=1:1 S APCDSWDA=$O(@(APCDSWG_""""_APCDSWCR_""",APCDSWV,APCDSWDA)")) Q:APCDSWDA="" S DIC=APCDSWG,Y=APCDSWDA D GETVAL,WRITE
S APCDSWI=APCDSWI-1
S APCDSWAN="" S:APCDSWI=1 APCDSWAN=APCDSWI
RDR I APCDSWAN="",APCDSWI R !!,"Choose: ",APCDSWAN:$S($D(DTIME):DTIME,1:300)
I APCDSWAN,$D(APCDSWT(APCDSWAN)) S APCDLOOK=APCDSWT(APCDSWAN)
I APCDLOOK,APCDSWD=9000010.07,$$VAL^XBDIQ1(APCDSWD,APCDLOOK,1101)]"",$G(APCDMNE("NAME"))="IPV" W !!,"You cannot use this mnemonic with a V POV that has been SNOMED coded.",! S APCDLOOK="" G RDRK
I APCDLOOK,APCDSWD=9000010.07,$$VAL^XBDIQ1(APCDSWD,APCDLOOK,1101)]"" D EN^XBNEW("MAP^APCDSW","APCDLOOK;VALM*")
RDRK K APCDSWV,APCDSWVA,APCDSWL,APCDSWCR,APCDSWD,APCDSWG,APCDSWDA,APCDSWI,APCDSWAN,APCDSWT,APCDSWN,APCDSWEX,APCDSWL,APCDSWP,APCDSWZ,APCDSWD2,APCDSWG2,APCDSWV2,Y
W !
Q
;
GETVAL ;
S APCDSWD2=APCDSWD,APCDSWG2=APCDSWG,APCDSWV2=APCDSWDA
F APCDSWL=0:0 S APCDSWVA=$P(@(APCDSWG2_APCDSWV2_",0)"),U) Q:$P(@("^DD("_APCDSWD2_",.01,0)"),U,2)'["P" S APCDSWG2=U_$P(^(0),U,3),APCDSWD2=+$P($P(^(0),U,2),"P",2),APCDSWV2=APCDSWVA
I APCDSWD2=9000010.64!(APCDSWD2=9000010.02) S APCDSWVA=$$FMTE^XLFDT(APCDSWVA)
Q
;
WRITE ;
NEW P,Q
W !,APCDSWI," ",APCDSWVA," "," ",$$VAL^XBDIQ1(APCDSWD,Y,.02)," ",$$VAL^XBDIQ1(APCDSWD,Y,.03)
I APCDSWD=9000010.07!(APCDSWD=9000010.08) W !?3,"Prov Narrative: ",$$VAL^XBDIQ1(APCDSWD,Y,.04)
I APCDSWD=9000010.07,$$VAL^XBDIQ1(APCDSWD,Y,1101)]"" W !?3,"SNOMED CT: ",$$VAL^XBDIQ1(APCDSWD,Y,1101) ;," - ",$$VAL^XBDIQ1(APCDSWD,Y,1101.019)
I APCDSWD=9000010.54 S APCDZ=Y D EN^XBNEW("DIQ^APCDSW","APCDZ")
W @("$E("_DIC_"Y,0),0)") ;RESET NAKED REFERENCE
S APCDSWN=0,APCDSWT(APCDSWI)=APCDSWDA F APCDSWL=0:0 S APCDSWN=$O(@("^DD("_APCDSWD_",0,""ID"",APCDSWN)")) Q:APCDSWN="" S APCDSWEX=^(APCDSWN) W @("$E("_DIC_"Y,0),0)") X APCDSWEX
Q
DIQ ;
F APCDF=2.01,2.02,1201:1:1204 I $D(^DD(9000010.54,APCDF,0)) S Z=$$VAL^XBDIQ1(9000010.54,APCDZ,APCDF) I Z]"" W !?2,$P(^DD(9000010.54,APCDF,0),U,1),": ",Z
Q
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 APCDSMC=$$VAL^XBDIQ1(9000010.07,APCDLOOK,1101)
;GET MAP ADVICE
S D=$$I10ADV^BSTSAPI("APCDSMA",APCDSMC)
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")=$P($G(^APCDSITE(DUZ(2),0)),U,37) S:DIR("B")="" DIR("B")="Y"
KILL DA
D ^DIR KILL DIR
I $D(DIRUT) Q
I 'Y Q
S X=0 F S X=$O(APCDV(X)) Q:X'=+X S APCDJ(X,0)=APCDV(X)
D DISPMAP
K APCDSMA,APCDSMC
Q
DISPMAP ;
NEW APCDHDR
S APCDHDR="Map Advice for Concept ID "_APCDSMC
D VIEWR^XBLM("DISPMAP1^APCDSW",APCDHDR)
Q
DISPMAP1 ;
W !,"Provider Narrative: "_$$VAL^XBDIQ1(9000010.07,APCDLOOK,.04)
W !,"FSN: "_$P($$CONC^AUPNVUTL(APCDSMC),U,2)
W !,"Patient's Age at visit: ",$$AGE^AUPNPAT($$VALI^XBDIQ1(9000010.07,APCDLOOK,.02),$$VD^APCLV($$VALI^XBDIQ1(9000010.07,APCDLOOK,.03)),"E")," ",$$VAL^XBDIQ1(2,$$VALI^XBDIQ1(9000010.07,APCDLOOK,.02),.02)
W !
NEW X S X=0 F S X=$O(APCDSMA(X)) Q:X'=+X W !,APCDSMA(X)
Q
APCDSW ; IHS/CMI/LAB - SWITCH TO V FILE ;
+1 ;;2.0;IHS PCC SUITE;**5,11,15,22**;MAY 14, 2009;Build 6
+2 ;
+3 ; APCDSWD=DICTIONARY NUMBER
+4 ; APCDSWCR=LINKING CROSS REFERENCE
+5 ; APCDSWV=VISIT DFN
+6 ;
+7 IF $GET(APCDVFIE)>0
SET APCDLOOK=APCDVFIE
QUIT
+8 SET U="^"
+9 SET APCDLOOK=""
+10 IF '$DATA(APCDSWV)
QUIT
+11 IF APCDSWV=""
QUIT
+12 IF '$DATA(APCDSWD)
QUIT
+13 IF 'APCDSWD
QUIT
+14 IF '$DATA(^DIC(APCDSWD,0,"GL"))
QUIT
+15 SET APCDSWG=^DIC(APCDSWD,0,"GL")
+16 IF '$DATA(APCDSWCR)
IF APCDSWD'=(APCDSWD\1)
IF APCDSWD\1=9000010
SET APCDSWCR="AD"
+17 IF '$DATA(APCDSWCR)
IF APCDSWD\1'=9000010
SET APCDSWCR="AC"
+18 IF '$DATA(APCDSWCR)
QUIT
+19 IF APCDSWCR=""
QUIT
+20 WRITE !
+21 SET APCDSWDA=0
FOR APCDSWI=1:1
SET APCDSWDA=$ORDER(@(APCDSWG_""""_APCDSWCR_""",APCDSWV,APCDSWDA)"))
IF APCDSWDA=""
QUIT
SET DIC=APCDSWG
SET Y=APCDSWDA
DO GETVAL
DO WRITE
+22 SET APCDSWI=APCDSWI-1
+23 SET APCDSWAN=""
IF APCDSWI=1
SET APCDSWAN=APCDSWI
RDR IF APCDSWAN=""
IF APCDSWI
READ !!,"Choose: ",APCDSWAN:$SELECT($DATA(DTIME):DTIME,1:300)
+1 IF APCDSWAN
IF $DATA(APCDSWT(APCDSWAN))
SET APCDLOOK=APCDSWT(APCDSWAN)
+2 IF APCDLOOK
IF APCDSWD=9000010.07
IF $$VAL^XBDIQ1(APCDSWD,APCDLOOK,1101)]""
IF $GET(APCDMNE("NAME"))="IPV"
WRITE !!,"You cannot use this mnemonic with a V POV that has been SNOMED coded.",!
SET APCDLOOK=""
GOTO RDRK
+3 IF APCDLOOK
IF APCDSWD=9000010.07
IF $$VAL^XBDIQ1(APCDSWD,APCDLOOK,1101)]""
DO EN^XBNEW("MAP^APCDSW","APCDLOOK;VALM*")
RDRK KILL APCDSWV,APCDSWVA,APCDSWL,APCDSWCR,APCDSWD,APCDSWG,APCDSWDA,APCDSWI,APCDSWAN,APCDSWT,APCDSWN,APCDSWEX,APCDSWL,APCDSWP,APCDSWZ,APCDSWD2,APCDSWG2,APCDSWV2,Y
+1 WRITE !
+2 QUIT
+3 ;
GETVAL ;
+1 SET APCDSWD2=APCDSWD
SET APCDSWG2=APCDSWG
SET APCDSWV2=APCDSWDA
+2 FOR APCDSWL=0:0
SET APCDSWVA=$PIECE(@(APCDSWG2_APCDSWV2_",0)"),U)
IF $PIECE(@("^DD("_APCDSWD2_",.01,0)"),U,2)'["P"
QUIT
SET APCDSWG2=U_$PIECE(^(0),U,3)
SET APCDSWD2=+$PIECE($PIECE(^(0),U,2),"P",2)
SET APCDSWV2=APCDSWVA
+3 IF APCDSWD2=9000010.64!(APCDSWD2=9000010.02)
SET APCDSWVA=$$FMTE^XLFDT(APCDSWVA)
+4 QUIT
+5 ;
WRITE ;
+1 NEW P,Q
+2 WRITE !,APCDSWI," ",APCDSWVA," "," ",$$VAL^XBDIQ1(APCDSWD,Y,.02)," ",$$VAL^XBDIQ1(APCDSWD,Y,.03)
+3 IF APCDSWD=9000010.07!(APCDSWD=9000010.08)
WRITE !?3,"Prov Narrative: ",$$VAL^XBDIQ1(APCDSWD,Y,.04)
+4 ;," - ",$$VAL^XBDIQ1(APCDSWD,Y,1101.019)
IF APCDSWD=9000010.07
IF $$VAL^XBDIQ1(APCDSWD,Y,1101)]""
WRITE !?3,"SNOMED CT: ",$$VAL^XBDIQ1(APCDSWD,Y,1101)
+5 IF APCDSWD=9000010.54
SET APCDZ=Y
DO EN^XBNEW("DIQ^APCDSW","APCDZ")
+6 ;RESET NAKED REFERENCE
WRITE @("$E("_DIC_"Y,0),0)")
+7 SET APCDSWN=0
SET APCDSWT(APCDSWI)=APCDSWDA
FOR APCDSWL=0:0
SET APCDSWN=$ORDER(@("^DD("_APCDSWD_",0,""ID"",APCDSWN)"))
IF APCDSWN=""
QUIT
SET APCDSWEX=^(APCDSWN)
WRITE @("$E("_DIC_"Y,0),0)")
XECUTE APCDSWEX
+8 QUIT
DIQ ;
+1 FOR APCDF=2.01,2.02,1201:1:1204
IF $DATA(^DD(9000010.54,APCDF,0))
SET Z=$$VAL^XBDIQ1(9000010.54,APCDZ,APCDF)
IF Z]""
WRITE !?2,$PIECE(^DD(9000010.54,APCDF,0),U,1),": ",Z
+2 QUIT
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 APCDSMC=$$VAL^XBDIQ1(9000010.07,APCDLOOK,1101)
+5 ;GET MAP ADVICE
+6 SET D=$$I10ADV^BSTSAPI("APCDSMA",APCDSMC)
+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")=$PIECE($GET(^APCDSITE(DUZ(2),0)),U,37)
IF DIR("B")=""
SET DIR("B")="Y"
+12 KILL DA
+13 DO ^DIR
KILL DIR
+14 IF $DATA(DIRUT)
QUIT
+15 IF 'Y
QUIT
+16 SET X=0
FOR
SET X=$ORDER(APCDV(X))
IF X'=+X
QUIT
SET APCDJ(X,0)=APCDV(X)
+17 DO DISPMAP
+18 KILL APCDSMA,APCDSMC
+19 QUIT
DISPMAP ;
+1 NEW APCDHDR
+2 SET APCDHDR="Map Advice for Concept ID "_APCDSMC
+3 DO VIEWR^XBLM("DISPMAP1^APCDSW",APCDHDR)
+4 QUIT
DISPMAP1 ;
+1 WRITE !,"Provider Narrative: "_$$VAL^XBDIQ1(9000010.07,APCDLOOK,.04)
+2 WRITE !,"FSN: "_$PIECE($$CONC^AUPNVUTL(APCDSMC),U,2)
+3 WRITE !,"Patient's Age at visit: ",$$AGE^AUPNPAT($$VALI^XBDIQ1(9000010.07,APCDLOOK,.02),$$VD^APCLV($$VALI^XBDIQ1(9000010.07,APCDLOOK,.03)),"E")," ",$$VAL^XBDIQ1(2,$$VALI^XBDIQ1(9000010.07,APCDLOOK,.02),.02)
+4 WRITE !
+5 NEW X
SET X=0
FOR
SET X=$ORDER(APCDSMA(X))
IF X'=+X
QUIT
WRITE !,APCDSMA(X)
+6 QUIT
