- 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