BGPGTXE ;cmi/anch/maw - ATX Gui Save Utilities 4/28/2005 9:22:40 AM
;;9.0;IHS CLINICAL REPORTING;**1**;JUL 01, 2009
;
;
;
;
;this routine will save from GUI applications
DEBUG(ATXRET,ATXSTR) ;-- call serenji debugger
;D DEBUG^%Serenji("TAX^ATXGE(.ATXRET,.ATXSTR)")
Q
;
Q
TAX(ATXRET,ATXSTR) ;EP -- save taxonomy
S X="MERR^BGPGTXU",@^%ZOSF("TRAP") ; m error trap
N P,ATXFL,ATXTAXN,ATXTAXF,ATXTAX,ATXI,ATXP,ATXERR,ATXTAXM,ATXTXG,ATXTXF,ATXTAXPF,ATXLOOK,ATXTX,ATXTXM
I ATXSTR="" D CATSTR^BGPGTXU(.ATXSTR,.ATXSTR)
K ^ATXTMP($J)
S ATXRET="^ATXTMP("_$J_")"
S ATXI=0
S ATXERR=""
S ^ATXTMP($J,ATXI)="T00080TAXONOMYSAVE"_$C(30)
S ATXI=ATXI+1
I $G(ATXSTR)="" S ^ATXTMP($J,ATXI)="Error Concatenating String for Taxonomy"_$C(30) Q
S P="|"
S ATXTAXN=$P(ATXSTR,P)
S ATXTAXF=$P(ATXSTR,P,2)
S ATXTXG="^ATXAX(""B"")"
S ATXTX="^ATXAX("
S ATXTXF=9002226
S ATXTXM=9002226.02101
I ATXTAXF="Lab" D
. S ATXTXG="^ATXLAB(""B"")"
. S ATXTX="^ATXLAB("
. S ATXTXF=9002228
. S ATXTXM=9002228.02101
. S ATXFL=60
S ATXTAX=$O(@ATXTXG@(ATXTAXN,0))
S ATXLOOK=0
I 'ATXTAX S ^ATXTMP($J,ATXI)="Taxonomy does not exist on System"_$C(30) Q
S ATXLOOK=0
I '$$GET1^DIQ(ATXTXF,ATXTAX,.13) S ATXLOOK=1
D CLEANTAX(ATXTX,ATXTAX)
F ATXP=3:1 S ATXTAXM=$P(ATXSTR,P,ATXP) Q:$G(ATXTAXM)="" D
. N ATXIENS,ATXFDA
. S ATXIENS="+2,"_ATXTAX_","
. I ATXLOOK D
.. N ATXGLF
.. I '$G(ATXFL) S ATXFL=$P($G(^ATXAX(ATXTAX,0)),U,15)
.. S ATXGLF=$G(^DIC(ATXFL,0,"GL"))
.. S ATXGLF=ATXGLF_"""B"")"
.. S ATXTAXM=$O(@ATXGLF@(ATXTAXM,0))
. I 'ATXLOOK D
.. S ATXTAXM=$P(ATXTAXM,"-")
.. S ATXTAXM=ATXTAXM_" "
. Q:$G(ATXTAXM)=""
. S ATXFDA(ATXTXM,ATXIENS,.01)=ATXTAXM
. I ATXTXM=9002226.02101 S ATXFDA(ATXTXM,ATXIENS,.02)=ATXTAXM
. D UPDATE^DIE("","ATXFDA","ATXIENS","ATXERR(1)")
S ^ATXTMP($J,ATXI+1)=$C(31)_$G(ATXERR)
Q
;
CLEANTAX(TAXF,TAX) ;EP -- remove existing entries from 21 multiple before adding
N ATXDA,TAXI,ATXAA
S TAXI=TAXF_TAX_",21)"
S DIK=TAXF_TAX_",21,",DA(1)=TAX
S ATXDA=0 F S ATXDA=$O(@TAXI@(ATXDA)) Q:'ATXDA D
. S DA=ATXDA
. D ^DIK
S ATXAA=TAXF_TAX_",21)"
K @ATXAA@("AA")
K DIK,DA
Q
;
LABTAX(ATXRET,ATXSTR) ;EP -- return the lab taxonomy
S X="MERR^BGPGTXU",@^%ZOSF("TRAP") ; m error trap
N P,ATXRFL,ATXI,ATXERR,ATXIEN,ATXTAXE,ATXTAX,ATXDA,ATXNONC,ATXXRF
N ATXGL,ATXGRF,ATXP
S P="|"
K ^ATXTMP($J)
S ATXRET="^ATXTMP("_$J_")"
S ATXI=0
S ATXERR=""
S ^ATXTMP($J,ATXI)="T00080LABTAXONOMY"_$C(30)
F ATXP=3:1 S ATXTAXE=$P(ATXSTR,P,ATXP) Q:$G(ATXTAXE)="" D
. Q:$G(ATXTAXE)=""
. ;S ATXTAXE=$P(ATXSTR,P)
. S ATXTAX=$O(^ATXLAB("B",ATXTAXE,0))
. Q:'$G(ATXTAX)
. S ATXNONC=$P($G(^ATXLAB(ATXTAX,0)),U,13)
. S ATXXRF=$P($G(^ATXLAB(ATXTAX,0)),U,14)
. S ATXFL=60
. S ATXGL=$G(^DIC(ATXFL,0,"GL"))
. S ATXDA=0 F S ATXDA=$O(^ATXLAB(ATXTAX,21,ATXDA)) Q:'ATXDA D
.. N ATXL,ATXH
.. S ATXI=ATXI+1
.. S ATXL=$P($G(^ATXLAB(ATXTAX,21,ATXDA,0)),U)
.. S ATXH=$P($G(^ATXLAB(ATXTAX,21,ATXDA,0)),U,2)
.. I (ATXL=ATXH)!($G(ATXH)="") D Q
... I $G(ATXXRF)="" D Q
.... S ATXGRF=ATXGL_""""_ATXL_""""_")"
.... S ^ATXTMP($J,ATXI)=$P($G(@ATXGRF@(0)),U)_$C(30)
... S ^ATXTMP($J,ATXI)=ATXL_$C(30)
.. S ATXGRF=ATXGL_""""_ATXXRF_""")"
.. N ATXIEN
.. S ATXIEN=$O(@ATXGRF@(ATXL),-1)
.. F S ATXIEN=$O(@ATXGRF@(ATXIEN)) Q:ATXIEN>ATXH D
... S ATXI=ATXI+1
... S ^ATXTMP($J,ATXI)=ATXIEN_$C(30)
S ^ATXTMP($J,ATXI+1)=$C(31)_$G(ATXERR)
Q
;
LTAX(ATXRET) ;EP -- generic lab taxonomy table
S X="MERR^BGPGTXU",@^%ZOSF("TRAP") ; m error trap
N P,ATXRFL,ATXI,ATXERR,ATXIEN,ATXTAXE,ATXTAX,ATXDA,ATXNONC,ATXXRF
N ATXGL,ATXGRF,ATXP,ATXPKG,ATXTDA,ATXPKGI
S P="|"
K ^ATXTMP($J)
S ATXRET="^ATXTMP("_$J_")"
S ATXI=0
S ATXERR=""
S ATXPKG=$P(ATXSTR,P,2)
S ATXPKGI=$O(^DIC(9.4,"C",ATXPKG,0))
S ^ATXTMP($J,ATXI)="T00080LABTAXONOMY"_$C(30)
S ATXTAX=0 F S ATXTAX=$O(^ATXLAB("APKG",ATXPKGI,ATXTAX)) Q:'ATXTAX D
. ;S ATXTAX=0 F S ATXTAX=$O(^ATXLAB(ATXTAX)) Q:'ATXTAX D
. ;S ATXTAX=$P($G(^ATXLAB(ATXP,0)),U)
. ;Q:$E($P($G(^ATXLAB(ATXTAX,0)),U),1,2)'="DM"
. ;S ATXTAXE=$P(ATXSTR,P)
. ;S ATXTAX=$O(^ATXLAB("B",ATXTAXE,0))
. ;Q:'$G(ATXTAX)
. S ATXXRF=$P($G(^ATXLAB(ATXTAX,0)),U,8)
. I $G(ATXXRF)="" S ATXXRF="B"
. S ATXFL=$P($G(^ATXLAB(ATXTAX,0)),U,9)
. S ATXGL=$G(^DIC(ATXFL,0,"GL"))
. S ATXDA=0 F S ATXDA=$O(^ATXLAB(ATXTAX,21,ATXDA)) Q:'ATXDA D
.. N ATXL,ATXH
.. S ATXI=ATXI+1
.. S ATXL=$P($G(^ATXLAB(ATXTAX,21,ATXDA,0)),U)
.. S ATXGRF=ATXGL_""""_ATXL_""""_")"
.. N ATXIEN
.. S ATXI=ATXI+1
.. S ^ATXTMP($J,ATXI)=$P($G(@ATXGRF@(0)),U)_$C(30)
S ^ATXTMP($J,ATXI+1)=$C(31)_$G(ATXERR)
Q
;
MEDBLD ;EP -- setup ATXSTR for medication taxonomy
S X="MERR^BGPGTXU",@^%ZOSF("TRAP") ; m error trap
N ATXTDA,ATXI,ATXPKG,ATXPKGI
S ATXI=1
S ATXPKG=$P(ATXSTR,P,2)
S ATXPKGI=$O(^DIC(9.4,"C",ATXPKG,0))
S ATXTDA=0 F S ATXTDA=$O(^ATXAX(ATXTDA)) Q:'ATXTDA D
. ;S ATXTDA=0 F S ATXTDA=$O(^ATXAX(ATXTDA)) Q:'ATXTDA D
. ;Q:$E($P($G(^ATXAX(ATXTDA,0)),U),1,2)'="DM"
. Q:$P($G(^ATXAX(ATXTDA,0)),U,15)'=50
. S ATXI=ATXI+1
. S $P(ATXSTR,P,ATXI)=$P($G(^ATXAX(ATXTDA,0)),U)
Q
;
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
+2 ;
+3 ;
+4 ;
+5 ;
+6 ;this routine will save from GUI applications
DEBUG(ATXRET,ATXSTR) ;-- call serenji debugger
+1 ;D DEBUG^%Serenji("TAX^ATXGE(.ATXRET,.ATXSTR)")
+2 QUIT
+3 ;
+4 QUIT
TAX(ATXRET,ATXSTR) ;EP -- save taxonomy
+1 ; m error trap
SET X="MERR^BGPGTXU"
SET @^%ZOSF("TRAP")
+2 NEW P,ATXFL,ATXTAXN,ATXTAXF,ATXTAX,ATXI,ATXP,ATXERR,ATXTAXM,ATXTXG,ATXTXF,ATXTAXPF,ATXLOOK,ATXTX,ATXTXM
+3 IF ATXSTR=""
DO CATSTR^BGPGTXU(.ATXSTR,.ATXSTR)
+4 KILL ^ATXTMP($JOB)
+5 SET ATXRET="^ATXTMP("_$JOB_")"
+6 SET ATXI=0
+7 SET ATXERR=""
+8 SET ^ATXTMP($JOB,ATXI)="T00080TAXONOMYSAVE"_$CHAR(30)
+9 SET ATXI=ATXI+1
+10 IF $GET(ATXSTR)=""
SET ^ATXTMP($JOB,ATXI)="Error Concatenating String for Taxonomy"_$CHAR(30)
QUIT
+11 SET P="|"
+12 SET ATXTAXN=$PIECE(ATXSTR,P)
+13 SET ATXTAXF=$PIECE(ATXSTR,P,2)
+14 SET ATXTXG="^ATXAX(""B"")"
+15 SET ATXTX="^ATXAX("
+16 SET ATXTXF=9002226
+17 SET ATXTXM=9002226.02101
+18 IF ATXTAXF="Lab"
Begin DoDot:1
+19 SET ATXTXG="^ATXLAB(""B"")"
+20 SET ATXTX="^ATXLAB("
+21 SET ATXTXF=9002228
+22 SET ATXTXM=9002228.02101
+23 SET ATXFL=60
End DoDot:1
+24 SET ATXTAX=$ORDER(@ATXTXG@(ATXTAXN,0))
+25 SET ATXLOOK=0
+26 IF 'ATXTAX
SET ^ATXTMP($JOB,ATXI)="Taxonomy does not exist on System"_$CHAR(30)
QUIT
+27 SET ATXLOOK=0
+28 IF '$$GET1^DIQ(ATXTXF,ATXTAX,.13)
SET ATXLOOK=1
+29 DO CLEANTAX(ATXTX,ATXTAX)
+30 FOR ATXP=3:1
SET ATXTAXM=$PIECE(ATXSTR,P,ATXP)
IF $GET(ATXTAXM)=""
QUIT
Begin DoDot:1
+31 NEW ATXIENS,ATXFDA
+32 SET ATXIENS="+2,"_ATXTAX_","
+33 IF ATXLOOK
Begin DoDot:2
+34 NEW ATXGLF
+35 IF '$GET(ATXFL)
SET ATXFL=$PIECE($GET(^ATXAX(ATXTAX,0)),U,15)
+36 SET ATXGLF=$GET(^DIC(ATXFL,0,"GL"))
+37 SET ATXGLF=ATXGLF_"""B"")"
+38 SET ATXTAXM=$ORDER(@ATXGLF@(ATXTAXM,0))
End DoDot:2
+39 IF 'ATXLOOK
Begin DoDot:2
+40 SET ATXTAXM=$PIECE(ATXTAXM,"-")
+41 SET ATXTAXM=ATXTAXM_" "
End DoDot:2
+42 IF $GET(ATXTAXM)=""
QUIT
+43 SET ATXFDA(ATXTXM,ATXIENS,.01)=ATXTAXM
+44 IF ATXTXM=9002226.02101
SET ATXFDA(ATXTXM,ATXIENS,.02)=ATXTAXM
+45 DO UPDATE^DIE("","ATXFDA","ATXIENS","ATXERR(1)")
End DoDot:1
+46 SET ^ATXTMP($JOB,ATXI+1)=$CHAR(31)_$GET(ATXERR)
+47 QUIT
+48 ;
CLEANTAX(TAXF,TAX) ;EP -- remove existing entries from 21 multiple before adding
+1 NEW ATXDA,TAXI,ATXAA
+2 SET TAXI=TAXF_TAX_",21)"
+3 SET DIK=TAXF_TAX_",21,"
SET DA(1)=TAX
+4 SET ATXDA=0
FOR
SET ATXDA=$ORDER(@TAXI@(ATXDA))
IF 'ATXDA
QUIT
Begin DoDot:1
+5 SET DA=ATXDA
+6 DO ^DIK
End DoDot:1
+7 SET ATXAA=TAXF_TAX_",21)"
+8 KILL @ATXAA@("AA")
+9 KILL DIK,DA
+10 QUIT
+11 ;
LABTAX(ATXRET,ATXSTR) ;EP -- return the lab taxonomy
+1 ; m error trap
SET X="MERR^BGPGTXU"
SET @^%ZOSF("TRAP")
+2 NEW P,ATXRFL,ATXI,ATXERR,ATXIEN,ATXTAXE,ATXTAX,ATXDA,ATXNONC,ATXXRF
+3 NEW ATXGL,ATXGRF,ATXP
+4 SET P="|"
+5 KILL ^ATXTMP($JOB)
+6 SET ATXRET="^ATXTMP("_$JOB_")"
+7 SET ATXI=0
+8 SET ATXERR=""
+9 SET ^ATXTMP($JOB,ATXI)="T00080LABTAXONOMY"_$CHAR(30)
+10 FOR ATXP=3:1
SET ATXTAXE=$PIECE(ATXSTR,P,ATXP)
IF $GET(ATXTAXE)=""
QUIT
Begin DoDot:1
+11 IF $GET(ATXTAXE)=""
QUIT
+12 ;S ATXTAXE=$P(ATXSTR,P)
+13 SET ATXTAX=$ORDER(^ATXLAB("B",ATXTAXE,0))
+14 IF '$GET(ATXTAX)
QUIT
+15 SET ATXNONC=$PIECE($GET(^ATXLAB(ATXTAX,0)),U,13)
+16 SET ATXXRF=$PIECE($GET(^ATXLAB(ATXTAX,0)),U,14)
+17 SET ATXFL=60
+18 SET ATXGL=$GET(^DIC(ATXFL,0,"GL"))
+19 SET ATXDA=0
FOR
SET ATXDA=$ORDER(^ATXLAB(ATXTAX,21,ATXDA))
IF 'ATXDA
QUIT
Begin DoDot:2
+20 NEW ATXL,ATXH
+21 SET ATXI=ATXI+1
+22 SET ATXL=$PIECE($GET(^ATXLAB(ATXTAX,21,ATXDA,0)),U)
+23 SET ATXH=$PIECE($GET(^ATXLAB(ATXTAX,21,ATXDA,0)),U,2)
+24 IF (ATXL=ATXH)!($GET(ATXH)="")
Begin DoDot:3
+25 IF $GET(ATXXRF)=""
Begin DoDot:4
+26 SET ATXGRF=ATXGL_""""_ATXL_""""_")"
+27 SET ^ATXTMP($JOB,ATXI)=$PIECE($GET(@ATXGRF@(0)),U)_$CHAR(30)
End DoDot:4
QUIT
+28 SET ^ATXTMP($JOB,ATXI)=ATXL_$CHAR(30)
End DoDot:3
QUIT
+29 SET ATXGRF=ATXGL_""""_ATXXRF_""")"
+30 NEW ATXIEN
+31 SET ATXIEN=$ORDER(@ATXGRF@(ATXL),-1)
+32 FOR
SET ATXIEN=$ORDER(@ATXGRF@(ATXIEN))
IF ATXIEN>ATXH
QUIT
Begin DoDot:3
+33 SET ATXI=ATXI+1
+34 SET ^ATXTMP($JOB,ATXI)=ATXIEN_$CHAR(30)
End DoDot:3
End DoDot:2
End DoDot:1
+35 SET ^ATXTMP($JOB,ATXI+1)=$CHAR(31)_$GET(ATXERR)
+36 QUIT
+37 ;
LTAX(ATXRET) ;EP -- generic lab taxonomy table
+1 ; m error trap
SET X="MERR^BGPGTXU"
SET @^%ZOSF("TRAP")
+2 NEW P,ATXRFL,ATXI,ATXERR,ATXIEN,ATXTAXE,ATXTAX,ATXDA,ATXNONC,ATXXRF
+3 NEW ATXGL,ATXGRF,ATXP,ATXPKG,ATXTDA,ATXPKGI
+4 SET P="|"
+5 KILL ^ATXTMP($JOB)
+6 SET ATXRET="^ATXTMP("_$JOB_")"
+7 SET ATXI=0
+8 SET ATXERR=""
+9 SET ATXPKG=$PIECE(ATXSTR,P,2)
+10 SET ATXPKGI=$ORDER(^DIC(9.4,"C",ATXPKG,0))
+11 SET ^ATXTMP($JOB,ATXI)="T00080LABTAXONOMY"_$CHAR(30)
+12 SET ATXTAX=0
FOR
SET ATXTAX=$ORDER(^ATXLAB("APKG",ATXPKGI,ATXTAX))
IF 'ATXTAX
QUIT
Begin DoDot:1
+13 ;S ATXTAX=0 F S ATXTAX=$O(^ATXLAB(ATXTAX)) Q:'ATXTAX D
+14 ;S ATXTAX=$P($G(^ATXLAB(ATXP,0)),U)
+15 ;Q:$E($P($G(^ATXLAB(ATXTAX,0)),U),1,2)'="DM"
+16 ;S ATXTAXE=$P(ATXSTR,P)
+17 ;S ATXTAX=$O(^ATXLAB("B",ATXTAXE,0))
+18 ;Q:'$G(ATXTAX)
+19 SET ATXXRF=$PIECE($GET(^ATXLAB(ATXTAX,0)),U,8)
+20 IF $GET(ATXXRF)=""
SET ATXXRF="B"
+21 SET ATXFL=$PIECE($GET(^ATXLAB(ATXTAX,0)),U,9)
+22 SET ATXGL=$GET(^DIC(ATXFL,0,"GL"))
+23 SET ATXDA=0
FOR
SET ATXDA=$ORDER(^ATXLAB(ATXTAX,21,ATXDA))
IF 'ATXDA
QUIT
Begin DoDot:2
+24 NEW ATXL,ATXH
+25 SET ATXI=ATXI+1
+26 SET ATXL=$PIECE($GET(^ATXLAB(ATXTAX,21,ATXDA,0)),U)
+27 SET ATXGRF=ATXGL_""""_ATXL_""""_")"
+28 NEW ATXIEN
+29 SET ATXI=ATXI+1
+30 SET ^ATXTMP($JOB,ATXI)=$PIECE($GET(@ATXGRF@(0)),U)_$CHAR(30)
End DoDot:2
End DoDot:1
+31 SET ^ATXTMP($JOB,ATXI+1)=$CHAR(31)_$GET(ATXERR)
+32 QUIT
+33 ;
MEDBLD ;EP -- setup ATXSTR for medication taxonomy
+1 ; m error trap
SET X="MERR^BGPGTXU"
SET @^%ZOSF("TRAP")
+2 NEW ATXTDA,ATXI,ATXPKG,ATXPKGI
+3 SET ATXI=1
+4 SET ATXPKG=$PIECE(ATXSTR,P,2)
+5 SET ATXPKGI=$ORDER(^DIC(9.4,"C",ATXPKG,0))
+6 SET ATXTDA=0
FOR
SET ATXTDA=$ORDER(^ATXAX(ATXTDA))
IF 'ATXTDA
QUIT
Begin DoDot:1
+7 ;S ATXTDA=0 F S ATXTDA=$O(^ATXAX(ATXTDA)) Q:'ATXTDA D
+8 ;Q:$E($P($G(^ATXAX(ATXTDA,0)),U),1,2)'="DM"
+9 IF $PIECE($GET(^ATXAX(ATXTDA,0)),U,15)'=50
QUIT
+10 SET ATXI=ATXI+1
+11 SET $PIECE(ATXSTR,P,ATXI)=$PIECE($GET(^ATXAX(ATXTDA,0)),U)
End DoDot:1
+12 QUIT
+13 ;
