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

APCLTAX1.m

Go to the documentation of this file. 
  1. APCLTAX1 ; IHS/CMI/LAB - TAXONOMY SYSTEM CON'T ;
  1.  ;;2.0;IHS PCC SUITE;;MAY 14, 2009
  1.  ;;
  1.  ;
  1. EN D CLEAR^VALM1
  1.  W !?5,"Select diagnosis(es) to add to the"
  1.  W !!?5,APCLTNAM," Taxonomy"
  1.  S DIR(0)="FO^1:20"
  1.  S DIR("A",1)="Enter a Diagnosis, an ICD Code"
  1.  S DIR("A")="or a Range of ICD9 codes"
  1.  S DIR("?",1)="    Enter a diagnosis such as: 'DIABETES'"
  1.  S DIR("?",2)="      or an ICD9 Code such as: '250.00'"
  1.  S DIR("?")="a range of ICD9 Codes such as: '250.00-250.93'"
  1.  W !
  1.  D DIR^APCLDIC
  1.  I X=""!$D(APCLQUIT) S APCLQUIT="" Q
  1.  D EVAL
  1.  Q
  1. EVAL ;EVALUATE USERS INPUT
  1.  K APCL,APCLX
  1.  N APCL1,APCL2
  1.  S APCL1=+$P(X,"-")
  1.  S APCL2=+$P(X,"-",2)
  1.  S APCL1=$TR(APCL1," ","")
  1.  S APCL2=$TR(APCL2," ","")
  1.  S:APCL1 APCLX(APCL1)=""
  1.  S:APCL2 APCLX(APCL2)=""
  1.  S APCLLOW=$O(APCLX(""))
  1.  S APCLHIGH=$S(APCLLOW]"":$O(APCLX(APCLLOW)),1:"")
  1.  S APCL("LOW")=""
  1.  S APCL("HIGH")=""
  1.  F APCLX="APCLLOW","APCLHIGH" D:APCLX]""
  1.  .S X=@APCLX
  1.  .S DIC="^ICD9("
  1.  .S DIC(0)="EMQZ"
  1.  .W !!
  1.  .D DIC^APCLDIC
  1.  .I +Y>0 D
  1.  ..S:APCLX="APCLLOW" APCL("LOW")=$P(Y(0),U)_U_$P(Y(0),U,3)
  1.  ..S:APCLX="APCLHIGH" APCL("HIGH")=$P(Y(0),U)_U_$P(Y(0),U,3)
  1.  I APCL("LOW")="",APCL("HIGH")="" S APCLQUIT="" Q
  1.  I APCL("LOW")="",APCL("HIGH")]"" S APCL("LOW")=APCL("HIGH"),APCL("HIGH")=""
  1.  D VERIFY
  1.  Q
  1. VERIFY W @IOF
  1.  D IN
  1.  I '$D(APCL("FINAL")) D
  1.  .W !!?5,"Add the following diagnos",$S(APCL("HIGH")]"":"es",1:"is")," to the"
  1.  .W !?5,APCLTNAM," Taxonomy"
  1.  I $D(APCL("FINAL")) D
  1.  .W !!?5,"You selected the range of diagnoses"
  1.  .W !?5,"listed below to add to this Taxonomy:"
  1.  I APCL("HIGH")]"" D
  1.  .W !!?5,$P(APCL("LOW"),U),?35,"-",?40,$P(APCL("HIGH"),U)
  1.  .W !?5,$P(APCL("LOW"),U,2),?35,"-",?40,$P(APCL("HIGH"),U,2)
  1.  I APCL("HIGH")="" D
  1.  .W !!?5,$P(APCL("LOW"),U),?35,$P(APCL("LOW"),U,2)
  1.  I $D(APCL("IN")) D
  1.  .W !!?5,"The diagnos",$S(APCL("HIGH")]"":"es",1:"is")," you chose overlap the existing range:"
  1.  .W !!?5,$P(APCL("IN"),U),?35,"-",?40,$P(APCL("IN"),U,2)
  1.  I $D(APCL("FINAL")) D
  1.  .W !!?5,"The range which includes all these diagnoses is:"
  1.  .W !!?5,$P(APCL("FINAL"),U),?35,"-",?40,$P(APCL("FINAL"),U,2)
  1.  S DIR(0)="YO"
  1.  S DIR("A")="Is this what you want"
  1.  S DIR("B")="YES"
  1.  W !
  1.  D DIR^APCLDIC
  1.  I Y'=1 S APCLQUIT="" Q
  1.  I $D(APCL("IN")) D
  1.  .S DA(1)=APCLTDA
  1.  .S DA=$P(APCL("IN"),U,3)
  1.  .S DIK="^ATXAX("_DA(1)_",21,"
  1.  .D DIK^APCLDIC
  1.  I $D(APCL("FINAL")) D
  1.  .S APCL("LOW")=$P(APCL("FINAL"),U)
  1.  .S APCL("HIGH")=$P(APCL("FINAL"),U,2)
  1.  Q
  1. IN ;CHECK IF SELECTED DX OR RANGE IS ALREADY IN ANOTHER RANGE
  1.  N X,Y,Z,APCLX
  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.  .I $P(Y,U)]"",$P(Y,U)'=$P(Y,U,2) S APCLX($P(Y,U))=X_U_$S($P(Y,U,2)]"":$P(Y,U,2),1:$P(Y,U))
  1.  S X=""
  1.  F  S X=$O(APCLX(X)) Q:X=""  D
  1.  .I $P(APCL("LOW"),U)=X!($P(APCL("LOW"),U)>X),$P(APCL("LOW"),U)<$P(APCLX(X),U,2) D
  1.  ..S APCL("IN")=X_U_$P(APCLX(X),U,2)_U_+APCLX(X)
  1.  ..S APCL("FINAL")=X_U_$S($P(APCLX(X),U,2)>$P(APCL("HIGH"),U):$P(APCLX(X),U,2),1:$P(APCL("HIGH"),U))
  1.  .I $P(APCL("LOW"),U)=X!($P(APCL("LOW"),U)<X),$P(APCL("HIGH"),U)>X D
  1.  ..S APCL("IN")=X_U_$P(APCLX(X),U,2)_U_+APCLX(X)
  1.  ..S APCL("FINAL")=$P(APCL("LOW"),U)_U_$S($P(APCLX(X),U,2)>$P(APCL("HIGH"),U):$P(APCLX(X),U,2),1:$P(APCL("HIGH"),U))
  1.  .I $P(APCL("LOW"),U)=X!($P(APCL("LOW"),U)<X),$P(APCL("HIGH"),U)>$P(APCLX(X),U,2) D
  1.  ..S APCL("IN")=X_U_$P(APCLX(X),U,2)_U_+APCLX(X)
  1.  ..S APCL("FINAL")=$P(APCL("LOW"),U)_U_$P(APCL("HIGH"),U)
  1.  Q
  1. Y ;EP;EVALUATE OUTPUT FROM TAXONOMY FOR PROPER EXTERNAL DISPLAY
  1.  S APCLLOW=$P(X,U),APCLHIGH=$P(X,U,2)
  1.  I "^RX^PATIENT ED TOPIC^HEALTH FACTORS^PROVIDER^OTHER^ADA CODE^"[(U_APCLANAM_U) D YCON
  1.  Q
  1. X ;EP;EVALUATE X FOR PROPER INTERNAL VALUE
  1.  I APCLANAM="OTHER",APCLCANN=0 D  Q
  1.  .I '+Y S X=Y(0,0)
  1.  .E  S X=+Y
  1.  .I $G(APCLTFNA)="COMMUNITY" S X=$P(^AUTTCOM(X,0),U)
  1.  I APCLANAM="OTHER",APCLCANN=1 S X=Y(0,0) Q
  1.  I APCLANAM="RX" S X=+Y Q
  1.  I APCLANAM="PATIENT ED TOPIC" S X=+Y Q
  1.  I APCLANAM="ADA CODE" S X=+Y Q
  1.  I APCLANAM="HEALTH FACTORS" S X=+Y Q
  1.  I APCLANAM="PROBLEM LIST DIAGNOSIS" S X=Y(0,0) Q
  1.  I APCLANAM="PROVIDER" S X=+Y Q
  1.  I APCLANAM="CURRENT COMMUNITY" S X=$P(^AUTTCOM(+Y,0),U)
  1.  Q
  1. LABTAX ;EP;PROCESS LAB TAXONOMIES
  1.  S APCLTNAM="DM AUDIT "_APCLX_" TAX"
  1.  S APCLTDA=$O(^ATXLAB("B",APCLTNAM,0))
  1.  I 'APCLTDA D LABTADD
  1.  Q:'APCLTDA
  1.  D LABTEST
  1.  Q
  1. LABTADD ;EP;ADD NEW LAB TAXONOMY
  1.  D CLEAR^VALM1
  1.  S DIR(0)="FO^3:30"
  1.  S DIR("A")="Taxonomy Name"
  1.  W !
  1.  D DIR^APCLDIC
  1.  I Y="" S APCLQUIT="" Q
  1.  I $D(^ATXLAB("B",Y)) W !!,"The ",Y," taxonomy already exists." G LABTADD
  1.  S (X,APCLTNAM)=Y
  1.  S APCLTNAM=Y
  1.  W !!,"The ",APCLTNAM," Lab Taxonomy does not exist on this system"
  1.  S DIR(0)="YO"
  1.  S DIR("A")="Do you want to create it now"
  1.  S DIR("B")="NO"
  1.  W !
  1.  D DIR^APCLDIC
  1.  I +Y'=1 S APCLTDA="" Q
  1.  S X=APCLTNAM
  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
  1. YCON ;CONVERT IEN TO EXTERNAL FORMAT FOR DISPLAY
  1.  I APCLANAM="OTHER" D OTHER Q
  1.  I APCLANAM="RX" D  Q
  1.  .N XX
  1.  .S XX=APCLLOW
  1.  .S APCLLOW=$P($G(^PSDRUG(+APCLLOW,0)),U)
  1.  .S APCLHIGH=""
  1.  .I $O(^PSDRUG(+XX,1,0)) D  ;IHS/CIM/THL PATCH 9
  1.  ..N X,Y,Z
  1.  ..S X=0
  1.  ..F  S X=$O(^PSDRUG(XX,1,X)) Q:'X  D
  1.  ...S Z="("
  1.  ...S Y=$P($G(^PSDRUG(XX,1,X,0)),U)
  1.  ...S:Y["" APCLHIGH=$S($G(Y)'["(":Z,1:"")_Y_", "
  1.  ..S:$L(APCLHIGH)>41 APCLHIGH=$E($G(APCLHIGH),1,40)_", "
  1.  ..S:$E(APCLHIGH,$L(APCLHIGH)-1,$L(APCLHIGH))=", " APCLHIGH=$E(APCLHIGH,1,$L(APCLHIGH)-2)_")"
  1.  ..;IHS/CIM/THL PATCH 9 END
  1.  .S:$G(APCLHIGH) APCLHIGH=$P($G(^PSDRUG(+APCLHIGH,0)),U)
  1.  .S APCLHIGH=APCLHIGH_"  ien: "_+XX
  1.  .D YCON1
  1.  I APCLANAM="PATIENT ED TOPIC" D  Q
  1.  .S APCLLOW=$P($G(^AUTTEDT(+APCLLOW,0)),U)
  1.  .S APCLHIGH=$P($G(^AUTTEDT(+APCLHIGH,0)),U)
  1.  .D YCON1
  1.  I APCLANAM="HEALTH FACTORS" D  Q
  1.  .S APCLLOW=$P($G(^AUTTHF(+APCLLOW,0)),U)
  1.  .S APCLHIGH=$P($G(^AUTTHF(+APCLHIGH,0)),U)
  1.  .D YCON1
  1.  I APCLANAM="ADA CODE" D  Q
  1.  .S APCLLOW=$P($G(^AUTTADA(+APCLLOW,0)),U)
  1.  .S APCLHIGH=$P($G(^AUTTADA(+APCLHIGH,0)),U)
  1.  .D YCON1
  1.  I APCLANAM="PROVIDER" D
  1.  .;S APCLLOW=$P($G(^DIC(16,+APCLLOW,0)),U)
  1.  .S APCLLOW=$$VAL^XBDIQ1($S($P(^DD(9000010.06,.01,0),U,2)[200:200,1:6),APCLLOW,.01)
  1.  .;S APCLHIGH=$P($G(^DIC(16,+APCLHIGH,0)),U)
  1.  .I APCLHIGH]"" S APCLHIGH=$$VAL^XBDIQ1($S($P(^DD(9000010.06,.01,0),U,2)[200:200,1:6),APCLHIGH,.01)
  1. YCON1 S:APCLHIGH=APCLLOW APCLHIGH=""
  1.  Q
  1. OTHER ;PROCESS FOR DISPLAY
  1.  Q:APCLCANN=1
  1.  Q:'APCLLOW
  1.  I APCLTFNA="ADA CODE" D  Q
  1.  .S APCLHIGH=$P($G(^AUTTADA(+APCLLOW,0)),U,2)
  1.  .S APCLLOW=$P($G(^AUTTADA(+APCLLOW,0)),U)
  1.  N X
  1.  S X=$G(^DIC(APCLFILE,0,"GL"))
  1.  Q:X=""
  1.  I $E(X,$L(X))="(" S X=$E(X,1,$L(X)-1)
  1.  E  I $E(X,$L(X))="," S X=$E(X,1,$L(X)-1)_")"
  1.  E  S X=X_")"
  1.  S APCLLOW=$P($G(@X@(+APCLLOW,0)),U)
  1.  S APCLHIGH=$P($G(@X@(+APCLHIGH,0)),U)
  1.  D YCON1
  1.  Q
  1. LABTEST ;EP;
  1.  D VALM^APCLTAX0("APCL LAB TAXONOMY DISPLAY")
  1.  Q
  1. TAXHEAD ;EP;PRINT HEADER FOR TAXONOMY MANAGEMENT
  1.  W @IOF
  1. TAXHEAD1 N X
  1.  F X="RPMS PATIENT CARE COMPONENT","TAXONOMY MANAGEMENT" D
  1.  .W !?(80-$L(X))\2,X
  1.  Q
  1. DXHEAD ;PRINT HEADER FOR TAXONOMY MANAGEMENT
  1.  W @IOF
  1.  D TAXHEAD1
  1.  N X
  1.  F X="Diagnosti/Medication Taxonomies"
  1.  W !?(80-$L(X))\2,X
  1.  Q
  1. LABHEAD ;EP;PRINT HEADER FOR TAXONOMY MANAGEMENT
  1.  W @IOF
  1.  N X
  1.  F X="Laboratory Taxonomies" D
  1.  .W !?(80-$L(X))\2,X
  1.  Q
  1. TAXDH ;DISPLAY HEADER FOR TAXONOMY SYSTEM
  1.  Q
  1. RXCLASS ;EP;ALLOW ADD OF ALL MEDS OF THE SAME DRUG CLASSIFICATION 
  1.  Q:'$P($G(^PSDRUG(APCLRXDA,"ND")),U,6)  S APCLRXVC=$P(^("ND"),U,6)
  1.  S DIR(0)="YO"
  1.  S DIR("A",1)="Add all Medications with the same"
  1.  S DIR("A")="VA Classification to this taxonomy"
  1.  S DIR("B")="NO"
  1.  W !
  1.  D DIR^APCLDIC
  1.  Q:Y'=1
  1.  N APCLX,APCLY,APCLZ
  1.  S APCLX=0
  1.  F  S APCLX=$O(^PSDRUG("VAC",APCLRXVC,APCLX)) Q:'APCLX  D
  1.  .S X=APCLX
  1.  .Q:$D(^ATXAX(APCLTDA,21,"B",X))
  1.  .S DA(1)=APCLTDA
  1.  .S DIC="^ATXAX("_APCLTDA_",21,"
  1.  .S DIC(0)="L"
  1.  .S DIC("DR")=".02////"_$P(APCL("HIGH"),U)
  1.  .S:'$D(^ATXAX(APCLTDA,21,0)) ^ATXAX(APCLTDA,21,0)="^9002226.02101A"
  1.  .D FILE^APCLDIC
  1.  Q
  1. LAB ;EP;
  1.  D VALM^APCLTAX0("APCL LAB TAXONOMY LIST")
  1.  Q
  1. SLAB ;EP;SELECT LAB TAXONOMY TO EDIT
  1.  Q:'$G(APCLJ)
  1.  S DIR(0)="NO^1:"_APCLJ
  1.  S DIR("A")="Edit which Lab Taxonomy"
  1.  W !
  1.  D DIR^APCLDIC
  1.  I '+Y S APCLQUIT="" Q
  1.  S APCLTDA=+APCLJ(Y)
  1.  S APCLTNAM=$P(APCLJ(Y),U,2)
  1.  D LABTEST
  1.  Q
  1. LABH ;LAB TAXONOMY HEADER
  1.  D VALM^APCLTAX0("APCL LAB TAXONOMY LIST")
  1.  Q
  1.  W @IOF
  1.  W !?10,"Select one of the LAB Taxonomies"
  1.  W !?10,"or ADD a NEW Lab Taxonomy"
  1.  W !!?5,"Select one of the following"
  1.  W !
  1.  S J=0
  1.  S X="DM AUDIT "
  1.  F  S X=$O(^ATXLAB("B",X)) Q:X=""!(X'["DM AUDIT")  D
  1.  .S Y=0
  1.  .F  S Y=$O(^ATXLAB("B",X,Y)) Q:'Y  D
  1.  ..S J=J+1
  1.  ..W !?10,$J(J,2),?15,$P($P(X,"DM AUDIT ",2)," TAX")
  1.  ..S J(J)=Y_U_X
  1.  S J=J+1
  1.  S APCLJ=J
  1.  W !?10,$J(J,2),?15,"Add NEW Lab Taxonomy"
  1.  Q
  1. TABACK S APCLGO="TAX"
  1.  D BACK^APCLTAX0
  1.  Q