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

APCLTAX0.m

Go to the documentation of this file. 
  1. APCLTAX0 ; IHS/CMI/LAB - DMS TAXONOMY MANAGEMENT UTILITY ;
  1.  ;;2.0;IHS PCC SUITE;;MAY 14, 2009
  1.  ;UTILITY PROGRAM TO MANAGE TAXONOMY CREATION AND EDITING
  1. TAX ;EP;TAXONOMY MANAGEMENT
  1.  W !!,"This taxonomy setup option has been disabled.  Each individual package"
  1.  W !,"that requires taxonomy setup will have it's own menu option for setting"
  1.  W !,"up the taxonomies required by the package.  For example, to update the"
  1.  W !,"taxonomies for the CRS report follow the menu path CI05-SET-TAX."
  1.  W !,"To update the taxonomies required by the 2005 Diabetes Audit use"
  1.  W !,"the taxonomy setup option provided in the 2005 Diabetes Audit menu.",!!
  1.  K DIR S DIR(0)="E",DIR("A")="Press enter: " D ^DIR K DIR
  1.  Q
  1.  F  D TAX1 Q:$D(APCLQUIT)!$D(APCLOUT)
  1. TAXEXIT K APCLQUIT,APCLOUT,APCLJ,APCLX,APCLY,APCLTDA,APCLTNAM,APCLINK,APCLINK0,APCLLDA,APCLWHCH,APCLADA,APCLANAM,APCLTF,APCLTFF,APCLCANN,APCLGO,APCLTFDA,APCLTFNA
  1.  K APCLHIGH,APCLLOW,APCLTYPE,APCLANAM,APCLCANN,APCLFILE,APCLILE,APLCGO,APLCJ,APCLRXDA,APCLRXVC,APCLTDA,APCLTNAM,APCLADA,APCLANAM
  1.  K ^TMP("APCLVR",$J)
  1.  Q
  1. TAX1 D TAXEXIT
  1.  D TAXHEAD^APCLTAX1
  1.  S VALMCNT=1
  1.  S DIR(0)="SO^1:Diabetes Mgt System Taxonomies;2:Other Taxonomies"
  1.  S DIR("A")="Which one"
  1.  D DIR^APCLDIC
  1.  I Y<1 S APCLQUIT="" Q
  1.  S APCLTYPE=$S(Y=1:"DMS",1:"OTHER")
  1.  I APCLTYPE="OTHER" D OTHER^APCLTAX2 Q
  1.  D TAXRX
  1.  Q
  1. TAXRX ;PROCESS TAXONOMIES
  1.  F  D TAXRX1 Q:$D(APCLQUIT)!$D(APCLOUT)
  1.  K APCLQUIT
  1.  Q
  1. TAXRX1 ;
  1.  W @IOF
  1.  W !?10,"Select one of the following ",!?10
  1.  W "Diabetes Mgt System Taxonomy"
  1.  W "Categories to review."
  1.  S DIR(0)="SO^1:Diagnosis;2:Medication;3:Patient Education Topic;4:Health Factors;5:Problem List Diagnosis;6:Provider;7:Lab;8:ADA Code"
  1.  S DIR("A")="Which one"
  1.  D DIR^APCLDIC
  1.  I Y<1 S APCLQUIT="" Q
  1.  S APCLWHCH=$S(Y=7:"LAB",1:"RX")
  1.  I Y=1 S APCLANAM="DIAGNOSIS"
  1.  I Y=2 S APCLANAM="RX"
  1.  I Y=3 S APCLANAM="PATIENT ED TOPIC"
  1.  I Y=4 S APCLANAM="HEALTH FACTORS"
  1.  I Y=5 S APCLANAM="PROBLEM LIST DIAGNOSIS"
  1.  I Y=6 S APCLANAM="PROVIDER"
  1.  I Y=7 S APCLANAM="LAB" D LAB^APCLTAX1 Q
  1.  I Y=8 S APCLANAM="ADA CODE"
  1.  S APCLADA=$O(^AMQQ(5,"B",APCLANAM,""))
  1.  I 'APCLADA D  Q
  1.  .W !!,"A taxonomy can not be created for this attribute.  Ask your"
  1.  .W !,"system manager to add ",APCLX," as an attribute then try again."
  1.  D TERM
  1.  Q:APCLINK0=""
  1.  D TAXDISP:APCLINK
  1.  Q
  1. TERM ;EP;SET QMAN DICTIONARY OF TERMS VALUES
  1.  S APCLINK=$P(^AMQQ(5,APCLADA,0),U,5)
  1.  S APCLINK0=$G(^AMQQ(1,APCLINK,0))
  1. APCLTF ;EP;
  1.  S APCLTF=U_$P(^AMQQ(5,APCLADA,0),U,18)
  1. APCLTF1 ;EP;
  1.  S:$E(APCLTF,$L(APCLTF))="(" APCLTFF=$E(APCLTF,1,$L(APCLTF)-1)
  1.  S:$E(APCLTF,$L(APCLTF))="," APCLTFF=$E(APCLTF,1,$L(APCLTF)-1)_")"
  1.  S (APCLFILE,APCLTFDA)=+$P($G(@APCLTFF@(0)),U,2)
  1.  S APCLTFNA=$P($G(@APCLTFF@(0)),U)
  1.  Q
  1. TAXDISP ;DISPLAY TAXONOMIES
  1.  D VALM("APCL TAXONOMY DISPLAY")
  1.  Q
  1.  S VALMSG="'-' Previous Page  'QU' Quit  ?? for More Actions"
  1.  Q
  1. TAXADD ;EP;ENTER A NEW TAXONOMY
  1.  D:'$G(APCLADA) ATTRIB^APCLTAX2
  1.  Q:'$G(APCLADA)
  1.  D APCLTF
  1.  I APCLANAM="DIAGNOSIS" S APCLCANN=1 ;CANONIC/NON-CANONIC
  1.  I APCLANAM="ADA CODE" S APCLCANN=0
  1.  I APCLANAM="RX" S APCLCANN=0
  1.  I APCLANAM="PROCEDURE (MEDICAL)" S APCLCANN=1
  1.  I APCLANAM="PATIENT ED TOPIC" S APCLCANN=0
  1.  I APCLANAM="HEALTH FACTORS" S APCLCANN=0
  1.  I APCLANAM="PROBLEM LIST DIAGNOSIS" S APCLCANN=1
  1.  I APCLANAM="PROVIDER" S APCLCANN=0
  1.  S DIR(0)="FO^3:30"
  1.  S DIR("A")="Taxonomy Name"
  1.  W !
  1.  D DIR^APCLDIC
  1.  I Y="" S APCLQUIT="" D TABACK Q
  1.  I $D(^ATXAX("B",Y)) W !!,"The ",Y," taxonomy already exists." G TAXADD
  1.  S (X,APCLTNAM)=Y
  1.  S DIC="^ATXAX("
  1.  S DIC(0)="L"
  1.  S DIC("DR")=".02////"_Y_";.05////"_DUZ_";.08////0;.09////"_DT_";.12////"_APCLINK_";.13////"_APCLCANN_";.15////"_+APCLTFDA
  1.  D FILE^APCLDIC
  1.  S APCLTDA=+Y
  1.  I 'APCLTDA D TABACK Q
  1.  D TILIST
  1. TABACK S APCLGO="TAX"
  1.  D BACK
  1.  Q
  1. TAXEDIT ;EP;EDIT AN EXISTING TAXONOMY
  1.  D SELECT
  1.  I $D(APCLQUIT) K APCLQUIT D TEBACK Q
  1. TE1 ;EP
  1.  D TILIST
  1. TEBACK S APCLGO="TAX"
  1.  D BACK
  1.  Q
  1. SELECT ;SELECT AN EXISTING TAXONOMY
  1.  S DIR(0)="NO^1:"_APCLJ
  1.  S DIR("A")="Which Taxonomy"
  1.  W !
  1.  D DIR^APCLDIC
  1.  I Y<1 S APCLQUIT="" Q
  1.  Q:'$D(APCLJ(Y))
  1.  S APCLTDA=+APCLJ(Y)
  1.  S APCLTNAM=$P($G(^ATXAX(+APCLTDA,0)),U)
  1.  Q
  1. EDIT ;EP;EDIT A TAXONOMY
  1.  S DA=APCLTDA
  1.  S DIE=$S(APCLWHCH="RX":"^ATXAX(",1:"^ATXLAB(")
  1.  S DR=$S(APCLWHCH="RX":"[APCL EDIT TAXONOMY]",1:"[APCL EDIT LAB TAXONOMY]")
  1.  D DDS^APCLDIC
  1.  S APCLGO="TAX"
  1.  D BACK
  1.  Q
  1. TAXINIT ;EP;INITIALIZE ARRAY FOR TAXONOMY DISPLAY
  1.  K ^TMP("APCLVR",$J),^TMP("APCLTMP",$J)
  1.  K APCLJ,VALMCNT S VALMCNT=0
  1.  D PROCESS^APCLTAX4
  1.  Q:'$D(APCLTAX)
  1.  N A,X,Y,Z
  1.  S X="     "_$S(APCLANAM'="RX":APCLANAM,1:"MEDICATION")_" Taxonomies"
  1.  D Z(X)
  1.  S X="  "
  1.  D Z(X)
  1.  S X="     No.  Taxonomy"
  1.  D Z(X)
  1.  S X="     ---  ------------------------------"
  1.  D Z(X)
  1.  S Z=0
  1.  S X=""
  1.  F  S X=$O(APCLTAX(X)) Q:X=""  D
  1.  .S Z=Z+1
  1.  .S A="    "_Z
  1.  .S:$L(A)=5 A=" "_A
  1.  .S A=A_"    "
  1.  .S A=A_X
  1.  .D Z(A)
  1.  .S APCLJ(Z)=+APCLTAX(X)_U_X
  1.  I '$D(^TMP("APCLVR",$J)) D
  1.  .S X="NO TAXONOMIES ON FILE FOR "_APCLX
  1.  .D Z(X)
  1.  S APCLJ=Z
  1.  Q
  1. VALM(APCLX) ;EP;VALM INTERFACE
  1.  S VALMCC=1 ;1=screen mode, 0=scrolling mode
  1.  D TERM^VALM0
  1.  D EN^VALM(APCLX)
  1.  D CLEAR^VALM1
  1.  Q
  1. LABADD ;EP;ADD LAB TO LAB TAXONOMY
  1.  F  D L1 Q:$D(APCLQUIT)
  1.  D BACK
  1.  Q
  1. L1 ;
  1.  D CLEAR^VALM1
  1.  W !,"Lab tests currently in this taxonomy:"
  1.  NEW X S X=0 F  S X=$O(^ATXLAB(APCLTDA,21,X)) Q:X'=+X  W !,$P(^LAB(60,$P(^ATXLAB(APCLTDA,21,X,0),U),0),U)
  1.  W !!,"Select lab tests to add."
  1.  S DIC="^LAB(60,"
  1.  S DIC(0)="AEMQZ"
  1.  S DIC("A")="Which LAB TEST: "
  1.  W !
  1.  D DIC^APCLDIC
  1.  I +Y<1 S APCLQUIT="" Q
  1.  I $D(^ATXLAB(APCLTDA,21,"B",+Y)) D  Q
  1.  .S APCLLDA=$O(^ATXLAB(APCLTDA,21,"B",+Y,0))
  1.  .W !!,Y(0,0)," already selected for this taxonomy." H 2
  1.  I '$D(^ATXLAB(APCLTDA,21,"B",Y(0,0)))&'$D(^ATXLAB(APCLTDA,21,"B",+Y)) D  I 1
  1.  .S DA(1)=APCLTDA
  1.  .S X=+Y
  1.  .S $P(^ATXLAB(DA(1),21,0),U,2)="9002228.02101PA"
  1.  .S DIC="^ATXLAB("_DA(1)_",21,"
  1.  .S DIC(0)="L"
  1.  .D FILE^APCLDIC
  1.  .S APCLLDA=+Y
  1. LE S DA=APCLLDA
  1.  S DA(1)=APCLTDA
  1.  S DIE="^ATXLAB("_DA(1)_",21,"
  1.  S DR="1101;"
  1.  D DIE^APCLDIC
  1.  Q
  1. LABEDIT ;EP;EDIT LAB IN LAB TAXONOMY
  1.  S DIR("A")="EDIT "
  1.  D SLAB
  1.  I $D(APCLQUIT) K APCLQUIT D BACK Q
  1.  D LE
  1.  D BACK
  1.  Q
  1. SLAB ;SELECT EXISTING LAB FROM LAB TAXONOMY
  1.  S DIR(0)="NO^1:"_APCLJ
  1.  S DIR("A")=$G(DIR("A"))_"Which Lab Test"
  1.  W !
  1.  D DIR^APCLDIC
  1.  I Y<1 S APCLQUIT="" Q
  1.  I '$D(APCLJ(APCLTDA,Y)) S APCLQUIT="" Q
  1.  S APCLLDA=+APCLJ(APCLTDA,Y)
  1.  Q
  1. DLAB ;EP;DELETE LAB FROM LAB TAXONOMY
  1.  S DIR("A")="DELETE "
  1.  D SLAB
  1.  I $D(APCLQUIT) K APCLQUIT D BACK Q
  1.  S DA(1)=APCLTDA
  1.  S DA=APCLLDA
  1.  S DIK="^ATXLAB("_DA(1)_",21,"
  1.  D DIK^APCLDIC
  1.  D BACK
  1.  Q
  1. TILIST ;EP;TO DISPLAY ITEMS ON TAXONOMY LIST
  1.  D VALM("APCL TAXONOMY ITEMS DISPLAY")
  1.  Q
  1. TIINIT ;EP;TO LIST ITEMS ON TAXONOMY
  1.  K APCLY
  1.  K ^TMP("APCLVR",$J),APCLJ
  1.  S VALMCNT=0
  1.  S X="     "_$P(^ATXAX(APCLTDA,0),U)
  1.  D Z(X)
  1.  S X="--------------------------------------"
  1.  D Z(X)
  1.  N A,B,X,Y,Z
  1.  S APCLX=""
  1.  F  S APCLX=$O(^ATXAX(APCLTDA,21,"B",APCLX)) Q:APCLX=""  D
  1.  .S APCLLDA=0
  1.  .F  S APCLLDA=$O(^ATXAX(APCLTDA,21,"B",APCLX,APCLLDA)) Q:'APCLLDA  D
  1.  ..S X=$G(^ATXAX(APCLTDA,21,APCLLDA,0))
  1.  ..Q:X=""
  1.  ..D Y^APCLTAX1
  1.  ..S APCLY(APCLLOW_" ")=APCLHIGH_U_APCLLDA
  1.  S APCLJ=0
  1.  S APCLLOW=""
  1.  F  S APCLLOW=$O(APCLY(APCLLOW)) Q:APCLLOW=""  D
  1.  .S APCLHIGH=$P(APCLY(APCLLOW),U)
  1.  .S APCLJ=APCLJ+1
  1.  .S A=""
  1.  .S $E(A,5)=APCLJ
  1.  .S:$L(A)=5 A=" "_A
  1.  .S A=A_"   "
  1.  .S A=A_APCLLOW_$E("                              ",1,30-$L(APCLLOW))
  1.  .S A=A_APCLHIGH_$E("                              ",1,30-$L(APCLHIGH))
  1.  .D Z(A)
  1.  .S APCLLDA=$P(APCLY(APCLLOW),U,2)
  1.  .S APCLJ(APCLTDA,APCLJ)=APCLLDA_U_A
  1.  Q
  1. TIADD ;EP;TO ADD ITEM TO TAXONOMY
  1.  I $P(^ATXAX(APCLTDA,0),U,22) W !!,"The ",$P(^ATXAX(APCLTDA,0),U)," taxonomy is READ ONLY.",!,"You cannot add items to it." D PAUSE Q
  1.  F  D TI1 Q:$D(APCLQUIT)
  1.  K APCLQUIT
  1.  Q
  1. TI1 K APCL
  1.  N X,Y,Z
  1.  I APCLANAM="DIAGNOSIS"!(APCLANAM="PROBLEM LIST DIAGNOSIS")!(APCLTFDA=80) D  I 1
  1.  .S X=0
  1.  .F  S X=$O(^ATXAX(APCLTDA,21,X)) Q:'X  D
  1.  ..S Y=$G(^ATXAX(APCLTDA,21,X,0))
  1.  ..S:$P(Y,U)]"" APCL(X)=$P(Y,U)_U_$S($P(Y,U,2)]"":$P(Y,U,2),1:$P(Y,U))
  1.  .D ^APCLTAX1
  1.  .Q:$D(APCLQUIT)
  1.  .S X=$P(APCL("LOW"),U)
  1.  E  D
  1.  .D CLEAR^VALM1
  1.  .W !?5,"Select an item to ADD to the"
  1.  .W !!?5,APCLTNAM," Taxonomy"
  1.  .S DIC=APCLTF
  1.  .S DIC(0)="AEMQZ"
  1.  .S DIC("A")="Which "_APCLANAM_": "
  1.  .S:APCLANAM="OTHER" DIC("A")="Which "_APCLTFNA_": "
  1.  .W !
  1.  .D DIC^APCLDIC
  1.  .I +Y<1 S APCLQUIT="" Q
  1.  .D X^APCLTAX1
  1.  .S APCL("LOW")=X
  1.  .S APCL("HIGH")=""
  1.  I $D(APCLQUIT) D TIBACK Q
  1.  S X=$P(APCL("LOW"),U)
  1.  S DA(1)=APCLTDA
  1.  S DIC="^ATXAX("_APCLTDA_",21,"
  1.  S DIC(0)="L"
  1.  S DIC("DR")=".02////"_$S($P(APCL("HIGH"),U)]"":$P(APCL("HIGH"),U),1:X)
  1.  S:'$D(^ATXAX(APCLTDA,21,0)) ^ATXAX(APCLTDA,21,0)="^9002226.02101A"
  1.  D FILE^APCLDIC:'$D(^ATXAX(APCLTDA,21,"B",X))
  1. TIBACK S APCLGO="TI"
  1.  D BACK
  1.  Q
  1. TIREMOVE ;EP;TO REMOVE ITEM FROM TAXONOMY
  1.  I $P(^ATXAX(APCLTDA,0),U,22) W !!,"The ",$P(^ATXAX(APCLTDA,0),U)," taxonomy is READ ONLY.",!,"You cannot remove items from it." D PAUSE Q
  1.  D TISEL
  1.  I $D(APCLQUIT) K APCLQUIT D TIBACK Q
  1.  N APCLI,APCLX
  1.  F APCLI=1:1 S APCLX=$P(APCLY,",",APCLI) Q:APCLX=""  D
  1.  .Q:'$D(APCLJ(APCLTDA,APCLX))
  1.  .S APCLLDA=+APCLJ(APCLTDA,APCLX)
  1.  .S DA(1)=APCLTDA
  1.  .S DA=APCLLDA
  1.  .S DIK="^ATXAX("_DA(1)_",21,"
  1.  .D DIK^APCLDIC
  1.  S APCLGO="TI"
  1.  D BACK
  1.  Q
  1. TISEL ;EP;SELECT EXISTING ITEM FROM A TAXONOMY
  1.  S DIR(0)="LO^1:"_APCLJ
  1.  S DIR("A")="Delete which Taxonomy Item(s)"
  1.  W !
  1.  D DIR^APCLDIC
  1.  I Y<1 S APCLQUIT="" Q
  1.  S APCLY=Y
  1.  Q
  1. BACK ;EP;SETUP FOR RETURN TO LISTMAN
  1.  S VALMBCK="R"
  1.  I APCLWHCH="LAB" D LABINIT^APCLTAX4 Q
  1.  D TAXINIT:APCLGO="TAX"
  1.  D TIINIT:APCLGO="TI"
  1.  D TERM^VALM0
  1.  Q
  1. Z(X) ;SET TMP NODE
  1.  S VALMCNT=$G(VALMCNT)+1
  1.  S ^TMP("APCLVR",$J,VALMCNT,0)=X
  1.  Q
  1. LADD ;EP
  1.  S DIR(0)="FO^3:30"
  1.  S DIR("A")="Taxonomy Name"
  1.  W !
  1.  D DIR^APCLDIC
  1.  I Y="" S APCLQUIT="" D TABACK Q
  1.  I $D(^ATXLAB("B",Y)) W !!,"The ",Y," taxonomy already exists." G LADD
  1.  S (X,APCLTNAM)=Y
  1.  S DIC="^ATXLAB("
  1.  S DIC(0)="L"
  1.  S DIC("DR")=".02////"_($P(APCLTNAM," TAX")_" TEST TAX")_";.05////"_DUZ_";.06////"_DT_";.08////B;.09////60"
  1.  D FILE^APCLDIC
  1.  S APCLTDA=+Y
  1.  Q:'APCLTDA
  1.  D LABTEST^APCLTAX1
  1.  Q
  1. PAUSE ;EP
  1.  Q:'(IO=IO(0))
  1.  Q:'($E(IOST,1,2)="C-")
  1.  S Y=$$DIR^XBDIR("EO")
  1.  S:$D(DUOUT) XBQ=1
  1.  Q
  1.  ;