Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCDSW

APCDSW.m

Go to the documentation of this file.
  1. APCDSW ; IHS/CMI/LAB - SWITCH TO V FILE ;
  1. ;;2.0;IHS PCC SUITE;**5,11,15,22**;MAY 14, 2009;Build 6
  1. ;
  1. ; APCDSWD=DICTIONARY NUMBER
  1. ; APCDSWCR=LINKING CROSS REFERENCE
  1. ; APCDSWV=VISIT DFN
  1. ;
  1. I $G(APCDVFIE)>0 S APCDLOOK=APCDVFIE Q
  1. S U="^"
  1. S APCDLOOK=""
  1. Q:'$D(APCDSWV)
  1. Q:APCDSWV=""
  1. Q:'$D(APCDSWD)
  1. Q:'APCDSWD
  1. Q:'$D(^DIC(APCDSWD,0,"GL"))
  1. S APCDSWG=^DIC(APCDSWD,0,"GL")
  1. I '$D(APCDSWCR),APCDSWD'=(APCDSWD\1),APCDSWD\1=9000010 S APCDSWCR="AD"
  1. I '$D(APCDSWCR),APCDSWD\1'=9000010 S APCDSWCR="AC"
  1. Q:'$D(APCDSWCR)
  1. Q:APCDSWCR=""
  1. W !
  1. S APCDSWDA=0 F APCDSWI=1:1 S APCDSWDA=$O(@(APCDSWG_""""_APCDSWCR_""",APCDSWV,APCDSWDA)")) Q:APCDSWDA="" S DIC=APCDSWG,Y=APCDSWDA D GETVAL,WRITE
  1. S APCDSWI=APCDSWI-1
  1. S APCDSWAN="" S:APCDSWI=1 APCDSWAN=APCDSWI
  1. RDR I APCDSWAN="",APCDSWI R !!,"Choose: ",APCDSWAN:$S($D(DTIME):DTIME,1:300)
  1. I APCDSWAN,$D(APCDSWT(APCDSWAN)) S APCDLOOK=APCDSWT(APCDSWAN)
  1. 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
  1. I APCDLOOK,APCDSWD=9000010.07,$$VAL^XBDIQ1(APCDSWD,APCDLOOK,1101)]"" D EN^XBNEW("MAP^APCDSW","APCDLOOK;VALM*")
  1. RDRK K APCDSWV,APCDSWVA,APCDSWL,APCDSWCR,APCDSWD,APCDSWG,APCDSWDA,APCDSWI,APCDSWAN,APCDSWT,APCDSWN,APCDSWEX,APCDSWL,APCDSWP,APCDSWZ,APCDSWD2,APCDSWG2,APCDSWV2,Y
  1. W !
  1. Q
  1. ;
  1. GETVAL ;
  1. S APCDSWD2=APCDSWD,APCDSWG2=APCDSWG,APCDSWV2=APCDSWDA
  1. 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
  1. I APCDSWD2=9000010.64!(APCDSWD2=9000010.02) S APCDSWVA=$$FMTE^XLFDT(APCDSWVA)
  1. Q
  1. ;
  1. WRITE ;
  1. NEW P,Q
  1. W !,APCDSWI," ",APCDSWVA," "," ",$$VAL^XBDIQ1(APCDSWD,Y,.02)," ",$$VAL^XBDIQ1(APCDSWD,Y,.03)
  1. I APCDSWD=9000010.07!(APCDSWD=9000010.08) W !?3,"Prov Narrative: ",$$VAL^XBDIQ1(APCDSWD,Y,.04)
  1. I APCDSWD=9000010.07,$$VAL^XBDIQ1(APCDSWD,Y,1101)]"" W !?3,"SNOMED CT: ",$$VAL^XBDIQ1(APCDSWD,Y,1101) ;," - ",$$VAL^XBDIQ1(APCDSWD,Y,1101.019)
  1. I APCDSWD=9000010.54 S APCDZ=Y D EN^XBNEW("DIQ^APCDSW","APCDZ")
  1. W @("$E("_DIC_"Y,0),0)") ;RESET NAKED REFERENCE
  1. 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
  1. Q
  1. DIQ ;
  1. 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
  1. Q
  1. MAP ;EP - CALLED FROM XBDBQUE
  1. S D=$$VD^APCLV($P(^AUPNVPOV(APCDLOOK,0),U,3))
  1. S D=$$IMP^AUPNSICD(D)
  1. I D'=30 Q ;ICD10 ONLY
  1. S APCDSMC=$$VAL^XBDIQ1(9000010.07,APCDLOOK,1101)
  1. ;GET MAP ADVICE
  1. S D=$$I10ADV^BSTSAPI("APCDSMA",APCDSMC)
  1. I 'D Q ;NO MAP ADVICE
  1. ;ASK TO DISPLAY
  1. W !!,"This POV has been SNOMED coded and there is map advice available."
  1. K DIR
  1. 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"
  1. KILL DA
  1. D ^DIR KILL DIR
  1. I $D(DIRUT) Q
  1. I 'Y Q
  1. S X=0 F S X=$O(APCDV(X)) Q:X'=+X S APCDJ(X,0)=APCDV(X)
  1. D DISPMAP
  1. K APCDSMA,APCDSMC
  1. Q
  1. DISPMAP ;
  1. NEW APCDHDR
  1. S APCDHDR="Map Advice for Concept ID "_APCDSMC
  1. D VIEWR^XBLM("DISPMAP1^APCDSW",APCDHDR)
  1. Q
  1. DISPMAP1 ;
  1. W !,"Provider Narrative: "_$$VAL^XBDIQ1(9000010.07,APCDLOOK,.04)
  1. W !,"FSN: "_$P($$CONC^AUPNVUTL(APCDSMC),U,2)
  1. 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)
  1. W !
  1. NEW X S X=0 F S X=$O(APCDSMA(X)) Q:X'=+X W !,APCDSMA(X)
  1. Q