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

BGPGTXE.m

Go to the documentation of this file. 
  1. BGPGTXE ;cmi/anch/maw - ATX Gui Save Utilities 4/28/2005 9:22:40 AM
  1.  ;;9.0;IHS CLINICAL REPORTING;**1**;JUL 01, 2009
  1.  ;
  1.  ;
  1.  ;
  1.  ;
  1.  ;this routine will save from GUI applications
  1. DEBUG(ATXRET,ATXSTR) ;-- call serenji debugger
  1.  ;D DEBUG^%Serenji("TAX^ATXGE(.ATXRET,.ATXSTR)")
  1.  Q
  1.  ;
  1.  Q
  1. TAX(ATXRET,ATXSTR) ;EP -- save taxonomy
  1.  S X="MERR^BGPGTXU",@^%ZOSF("TRAP") ; m error trap
  1.  N P,ATXFL,ATXTAXN,ATXTAXF,ATXTAX,ATXI,ATXP,ATXERR,ATXTAXM,ATXTXG,ATXTXF,ATXTAXPF,ATXLOOK,ATXTX,ATXTXM
  1.  I ATXSTR="" D CATSTR^BGPGTXU(.ATXSTR,.ATXSTR)
  1.  K ^ATXTMP($J)
  1.  S ATXRET="^ATXTMP("_$J_")"
  1.  S ATXI=0
  1.  S ATXERR=""
  1.  S ^ATXTMP($J,ATXI)="T00080TAXONOMYSAVE"_$C(30)
  1.  S ATXI=ATXI+1
  1.  I $G(ATXSTR)="" S ^ATXTMP($J,ATXI)="Error Concatenating String for Taxonomy"_$C(30) Q
  1.  S P="|"
  1.  S ATXTAXN=$P(ATXSTR,P)
  1.  S ATXTAXF=$P(ATXSTR,P,2)
  1.  S ATXTXG="^ATXAX(""B"")"
  1.  S ATXTX="^ATXAX("
  1.  S ATXTXF=9002226
  1.  S ATXTXM=9002226.02101
  1.  I ATXTAXF="Lab" D
  1.  . S ATXTXG="^ATXLAB(""B"")"
  1.  . S ATXTX="^ATXLAB("
  1.  . S ATXTXF=9002228
  1.  . S ATXTXM=9002228.02101
  1.  . S ATXFL=60
  1.  S ATXTAX=$O(@ATXTXG@(ATXTAXN,0))
  1.  S ATXLOOK=0
  1.  I 'ATXTAX S ^ATXTMP($J,ATXI)="Taxonomy does not exist on System"_$C(30) Q
  1.  S ATXLOOK=0
  1.  I '$$GET1^DIQ(ATXTXF,ATXTAX,.13) S ATXLOOK=1
  1.  D CLEANTAX(ATXTX,ATXTAX)
  1.  F ATXP=3:1 S ATXTAXM=$P(ATXSTR,P,ATXP) Q:$G(ATXTAXM)=""  D
  1.  . N ATXIENS,ATXFDA
  1.  . S ATXIENS="+2,"_ATXTAX_","
  1.  . I ATXLOOK D
  1.  .. N ATXGLF
  1.  .. I '$G(ATXFL) S ATXFL=$P($G(^ATXAX(ATXTAX,0)),U,15)
  1.  .. S ATXGLF=$G(^DIC(ATXFL,0,"GL"))
  1.  .. S ATXGLF=ATXGLF_"""B"")"
  1.  .. S ATXTAXM=$O(@ATXGLF@(ATXTAXM,0))
  1.  . I 'ATXLOOK D
  1.  .. S ATXTAXM=$P(ATXTAXM,"-")
  1.  .. S ATXTAXM=ATXTAXM_" "
  1.  . Q:$G(ATXTAXM)=""
  1.  . S ATXFDA(ATXTXM,ATXIENS,.01)=ATXTAXM
  1.  . I ATXTXM=9002226.02101 S ATXFDA(ATXTXM,ATXIENS,.02)=ATXTAXM
  1.  . D UPDATE^DIE("","ATXFDA","ATXIENS","ATXERR(1)")
  1.  S ^ATXTMP($J,ATXI+1)=$C(31)_$G(ATXERR)
  1.  Q
  1.  ;
  1. CLEANTAX(TAXF,TAX) ;EP -- remove existing entries from 21 multiple before adding
  1.  N ATXDA,TAXI,ATXAA
  1.  S TAXI=TAXF_TAX_",21)"
  1.  S DIK=TAXF_TAX_",21,",DA(1)=TAX
  1.  S ATXDA=0 F  S ATXDA=$O(@TAXI@(ATXDA)) Q:'ATXDA  D
  1.  . S DA=ATXDA
  1.  . D ^DIK
  1.  S ATXAA=TAXF_TAX_",21)"
  1.  K @ATXAA@("AA")
  1.  K DIK,DA
  1.  Q
  1.  ;
  1. LABTAX(ATXRET,ATXSTR) ;EP -- return the lab taxonomy
  1.  S X="MERR^BGPGTXU",@^%ZOSF("TRAP") ; m error trap
  1.  N P,ATXRFL,ATXI,ATXERR,ATXIEN,ATXTAXE,ATXTAX,ATXDA,ATXNONC,ATXXRF
  1.  N ATXGL,ATXGRF,ATXP
  1.  S P="|"
  1.  K ^ATXTMP($J)
  1.  S ATXRET="^ATXTMP("_$J_")"
  1.  S ATXI=0
  1.  S ATXERR=""
  1.  S ^ATXTMP($J,ATXI)="T00080LABTAXONOMY"_$C(30)
  1.  F ATXP=3:1 S ATXTAXE=$P(ATXSTR,P,ATXP) Q:$G(ATXTAXE)=""  D
  1.  . Q:$G(ATXTAXE)=""
  1.  . ;S ATXTAXE=$P(ATXSTR,P)
  1.  . S ATXTAX=$O(^ATXLAB("B",ATXTAXE,0))
  1.  . Q:'$G(ATXTAX)
  1.  . S ATXNONC=$P($G(^ATXLAB(ATXTAX,0)),U,13)
  1.  . S ATXXRF=$P($G(^ATXLAB(ATXTAX,0)),U,14)
  1.  . S ATXFL=60
  1.  . S ATXGL=$G(^DIC(ATXFL,0,"GL"))
  1.  . S ATXDA=0 F  S ATXDA=$O(^ATXLAB(ATXTAX,21,ATXDA)) Q:'ATXDA  D
  1.  .. N ATXL,ATXH
  1.  .. S ATXI=ATXI+1
  1.  .. S ATXL=$P($G(^ATXLAB(ATXTAX,21,ATXDA,0)),U)
  1.  .. S ATXH=$P($G(^ATXLAB(ATXTAX,21,ATXDA,0)),U,2)
  1.  .. I (ATXL=ATXH)!($G(ATXH)="") D  Q
  1.  ... I $G(ATXXRF)="" D  Q
  1.  .... S ATXGRF=ATXGL_""""_ATXL_""""_")"
  1.  .... S ^ATXTMP($J,ATXI)=$P($G(@ATXGRF@(0)),U)_$C(30)
  1.  ... S ^ATXTMP($J,ATXI)=ATXL_$C(30)
  1.  .. S ATXGRF=ATXGL_""""_ATXXRF_""")"
  1.  .. N ATXIEN
  1.  .. S ATXIEN=$O(@ATXGRF@(ATXL),-1)
  1.  .. F  S ATXIEN=$O(@ATXGRF@(ATXIEN)) Q:ATXIEN>ATXH  D
  1.  ... S ATXI=ATXI+1
  1.  ... S ^ATXTMP($J,ATXI)=ATXIEN_$C(30)
  1.  S ^ATXTMP($J,ATXI+1)=$C(31)_$G(ATXERR)
  1.  Q
  1.  ;
  1. LTAX(ATXRET) ;EP -- generic lab taxonomy table
  1.  S X="MERR^BGPGTXU",@^%ZOSF("TRAP") ; m error trap
  1.  N P,ATXRFL,ATXI,ATXERR,ATXIEN,ATXTAXE,ATXTAX,ATXDA,ATXNONC,ATXXRF
  1.  N ATXGL,ATXGRF,ATXP,ATXPKG,ATXTDA,ATXPKGI
  1.  S P="|"
  1.  K ^ATXTMP($J)
  1.  S ATXRET="^ATXTMP("_$J_")"
  1.  S ATXI=0
  1.  S ATXERR=""
  1.  S ATXPKG=$P(ATXSTR,P,2)
  1.  S ATXPKGI=$O(^DIC(9.4,"C",ATXPKG,0))
  1.  S ^ATXTMP($J,ATXI)="T00080LABTAXONOMY"_$C(30)
  1.  S ATXTAX=0 F  S ATXTAX=$O(^ATXLAB("APKG",ATXPKGI,ATXTAX)) Q:'ATXTAX  D
  1.  . ;S ATXTAX=0 F  S ATXTAX=$O(^ATXLAB(ATXTAX)) Q:'ATXTAX  D
  1.  . ;S ATXTAX=$P($G(^ATXLAB(ATXP,0)),U)
  1.  . ;Q:$E($P($G(^ATXLAB(ATXTAX,0)),U),1,2)'="DM"
  1.  . ;S ATXTAXE=$P(ATXSTR,P)
  1.  . ;S ATXTAX=$O(^ATXLAB("B",ATXTAXE,0))
  1.  . ;Q:'$G(ATXTAX)
  1.  . S ATXXRF=$P($G(^ATXLAB(ATXTAX,0)),U,8)
  1.  . I $G(ATXXRF)="" S ATXXRF="B"
  1.  . S ATXFL=$P($G(^ATXLAB(ATXTAX,0)),U,9)
  1.  . S ATXGL=$G(^DIC(ATXFL,0,"GL"))
  1.  . S ATXDA=0 F  S ATXDA=$O(^ATXLAB(ATXTAX,21,ATXDA)) Q:'ATXDA  D
  1.  .. N ATXL,ATXH
  1.  .. S ATXI=ATXI+1
  1.  .. S ATXL=$P($G(^ATXLAB(ATXTAX,21,ATXDA,0)),U)
  1.  .. S ATXGRF=ATXGL_""""_ATXL_""""_")"
  1.  .. N ATXIEN
  1.  .. S ATXI=ATXI+1
  1.  .. S ^ATXTMP($J,ATXI)=$P($G(@ATXGRF@(0)),U)_$C(30)
  1.  S ^ATXTMP($J,ATXI+1)=$C(31)_$G(ATXERR)
  1.  Q
  1.  ;
  1. MEDBLD ;EP -- setup ATXSTR for medication taxonomy
  1.  S X="MERR^BGPGTXU",@^%ZOSF("TRAP") ; m error trap
  1.  N ATXTDA,ATXI,ATXPKG,ATXPKGI
  1.  S ATXI=1
  1.  S ATXPKG=$P(ATXSTR,P,2)
  1.  S ATXPKGI=$O(^DIC(9.4,"C",ATXPKG,0))
  1.  S ATXTDA=0 F  S ATXTDA=$O(^ATXAX(ATXTDA)) Q:'ATXTDA  D
  1.  . ;S ATXTDA=0 F  S ATXTDA=$O(^ATXAX(ATXTDA)) Q:'ATXTDA  D
  1.  . ;Q:$E($P($G(^ATXAX(ATXTDA,0)),U),1,2)'="DM"
  1.  . Q:$P($G(^ATXAX(ATXTDA,0)),U,15)'=50
  1.  . S ATXI=ATXI+1
  1.  . S $P(ATXSTR,P,ATXI)=$P($G(^ATXAX(ATXTDA,0)),U)
  1.  Q
  1.  ;