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

APCLTAX3.m

Go to the documentation of this file. 
  1. APCLTAX3 ; 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 ;CREATE TAXONOMIES
  1.  K ^TMP("TAXONOMIES",$J)
  1.  S APCLJ=0
  1.  S Y="S APCLJ=APCLJ+1 S ^TMP(""TAXONOMIES"",$J,APCLJ)=XX W ""."""
  1.  F A="DM AUDIT","SURVEILLANCE","APCH DM" D
  1.  .S AA=A
  1.  .F  S A=$O(^ATXAX("B",A)) Q:A'[AA  D
  1.  ..S B=0
  1.  ..F  S B=$O(^ATXAX("B",A,B)) Q:'B  D
  1.  ...S XX=" ;;0;;AX;;"_^ATXAX(B,0)
  1.  ...X Y
  1.  ...S C=0
  1.  ...F  S C=$O(^ATXAX(B,11,C)) Q:'C  D
  1.  ....S XX=" ;;11;;AX;;"_C_";;"_^ATXAX(B,11,C,0)
  1.  ....X Y
  1.  ...S C=0
  1.  ...F  S C=$O(^ATXAX(B,21,C)) Q:C  D
  1.  ....S (YY,YYY)=+$P(^ATXAX(B,0),U,15)
  1.  ....S XX=" ;;21;;AX;;"_C_";;"_^ATXAX(B,21,C,0),ZZ=$P(^(0),U)
  1.  ....I YY,"^9999999.31^80^80.1^"'[(U_YY_U) D
  1.  .....S YY=$G(^DIC(YY,0,"GL"))
  1.  .....Q:YY=""
  1.  .....S YY=$P($G(@(YY_+ZZ_",0)")),U)
  1.  .....S:YY]"" XX=XX_";;"_YY
  1.  ....I YYY=50,$P($G(^PSDRUG(ZZ,2)),U,4)["-" S $P(XX,";;",10)=$P(^(2),U,4)
  1.  ....X Y
  1.  S (A,AA)="DM AUDIT"
  1.  F  S A=$O(^ATXLAB("B",A)) Q:A'[AA  D
  1.  .S B=0
  1.  .F  S B=$O(^ATXLAB("B",A,B)) Q:'B  D
  1.  ..S XX=" ;;0;;LAB;;"_^ATXLAB(B,0)
  1.  ..X Y
  1.  ..S C=0
  1.  ..F  S C=$O(^ATXLAB(B,11,C)) Q:'C  D
  1.  ...S XX=" ;;11;;LAB;;"_C_";;"_^ATXLAB(B,11,C,0)
  1.  ...X Y
  1.  ..S C=0
  1.  ..F  S C=$O(^ATXLAB(B,21,C)) Q:C  D
  1.  ...S XX=" ;;21;;LAB;;"_C_";;"_^ATXLAB(B,21,C,0),ZZ=$P(^(0),U)
  1.  ...S YY=$P($G(^LAB(60,+ZZ,0)),U)
  1.  ...S XX=XX_";;"_$P($G(^LAB(60,+ZZ,0)),U)_";;"_$P($G(^(0)),U,12)
  1.  ...X Y
  1.  ...S D=0
  1.  ...F  S D=$O(^ATXLAB(B,21,C,11,D)) Q:'D  D
  1.  ....S YY=$P(^ATXLAB(B,0),U,9)
  1.  ....S XX=" ;;21;;LAB;;"_C_";;"_D_";;SOURCE;;"_^ATXLAB(B,21,C,11,D,0)
  1.  ....X Y
  1.  Q
  1. ZIS ;EP;
  1.  W !!,"This process will update Taxonomies required by the"
  1.  W !,"DIABETES MANAGEMENT SYSTEM."
  1.  W !!,"Select the device on which to record taxonomies updated."
  1.  W !!,"Enter the name of a device for the report or"
  1.  W !,"enter '^' to exit the update process then press <ENTER>."
  1.  S DIR(0)="YO"
  1.  S DIR("A")="Do you want to proceed"
  1.  S DIR("B")="YES"
  1.  W !
  1.  D DIR^APCLDIC
  1.  Q:Y'=1
  1.  D TAXSET
  1.  Q
  1. TAXSET ;EP;TO UPDATE DIABETES SYSTEM STANDARD TAXONOMIES
  1.  D T1
  1.  K ^TMP("TAXONOMIES",$J)
  1.  Q
  1. T1 K APCLDA,APCLQUIT
  1.  S APCLJ=0
  1.  F  S APCLJ=$O(^TMP("TAXONOMIES",$J,APCLJ)) Q:'APCLJ  S Z=^TMP("TAXONOMIES",$J,APCLJ) D
  1.  .I $P(Z,";;",2)=0 D  Q
  1.  ..S X=$P($P(Z,";;",4),U)
  1.  ..S APCLILE=$P($P(Z,";;",4),U,$S($P(Z,";;",3)="AX":15,1:9))
  1.  ..S (APCLDIC,DIC)=$S($P(Z,";;",3)="AX":"^ATXAX(",1:"^ATXLAB(")
  1.  ..I $D(@(DIC_"""B"","""_X_""")")) S APCLDA=$O(^(X,0)) Q
  1.  ..I '$D(ZTQUEUED) U IO W !,"FILE NEW TAXONOMY: ",X
  1.  ..S DIC(0)="L"
  1.  ..D FILE^APCLDIC
  1.  ..S APCLDA=+Y
  1.  ..S @(APCLDIC_APCLDA_",0)")=$P(Z,";;",4,99),$P(^(0),U,5)=DUZ
  1.  ..S DA=APCLDA
  1.  ..S DIK=APCLDIC
  1.  ..D IX1^APCLDIC
  1.  .Q:'$G(APCLDA)
  1.  .I $P(Z,";;",3)'="LAB" D DX
  1.  .I $P(Z,";;",3)="LAB" D LAB
  1.  Q
  1. DX I $P(Z,";;",2)=11 D
  1.  .I '$D(^ATXAX(APCLDA,11,$P(Z,";;",4),0)) D
  1.  ..S ^ATXAX(APCLDA,11,$P(Z,";;",4),0)=$P(Z,";;",5)
  1.  ..S ^ATXAX(APCLDA,11,0)="^^"_$P(Z,";;",4)_"^"_$P(Z,";;",4)_"^"_DT
  1.  ..I '$D(ZTQUEUED) U IO W !,"FILE DX DESCRIPTION: ",Z
  1.  I $P(Z,";;",2)=21 D
  1.  .S X=$P(Z,";;",6)
  1.  .S:X="" X=$P(Z,";;",5)
  1.  .Q:X=""
  1.  .S YY=$P(X,U),ZZ=$P(X,U,2)
  1.  .I YY]"","^9999999.31^80^80.1^"'[(U_APCLILE_U) D  Q:'YY
  1.  ..S YYY=$G(^DIC(APCLILE,0,"GL"))
  1.  ..Q:YYY=""
  1.  ..I APCLILE=50,$P(Z,";;",10)]"" S YY=$P(Z,";;",10),YY=$TR(YY,"-",""),YY=$O(^PSDRUG("ZNDC",YY,0)) Q:$D(^PSDRUG(+YY,0))
  1.  ..S YY=$P(X,U)
  1.  ..S YY=$O(@(YYY_"""B"","""_YY_""",0)"))
  1.  ..I ZZ]"" S ZZ=$O(@(YYY_"""B"","""_ZZ_""",0)"))
  1.  .S:ZZ="" ZZ=YY
  1.  .Q:$D(^ATXAX(APCLDA,21,"B",YY))
  1.  .I '$D(ZTQUEUED) U IO W !?10,"FILE DX ITEM: ",X," ",YY," ",ZZ
  1.  .S X=YY
  1.  .S DA=APCLDA
  1.  .S DA(1)=APCLDA
  1.  .S DIC="^ATXAX("_DA_",21,"
  1.  .I $G(ZZ)]"" S DIC("DR")=".02////"_ZZ K ZZ
  1.  .S:'$D(^ATXAX(DA,21,0)) ^ATXAX(DA,21,0)="^9002226.02101A"
  1.  .S DIC(0)="L"
  1.  .D FILE^APCLDIC
  1.  Q
  1. LAB I $P(Z,";;",2)=11 D  Q
  1.  .I '$D(^ATXLAB(APCLDA,11,$P(Z,";;",4),0)) D
  1.  ..S ^ATXLAB(APCLDA,11,$P(Z,";;",4),0)=$P(Z,";;",5)
  1.  ..S ^ATXLAB(APCLDA,11,0)="^^"_$P(Z,";;",4)_"^"_$P(Z,";;",4)_"^"_DT
  1.  ..I '$D(ZTQUEUED) U IO W !,"FILE LAB DESCRIPTION: ",Z
  1.  I $P(Z,";;",2)=21,$P(Z,";;",6)'="SOURCE" D
  1.  .S YY=$P(Z,";;",5)
  1.  .I $P($G(^LAB(60,YY,0)),U,12)=$P(Z,";;",7)
  1.  .E  D
  1.  ..S YY=$P(Z,";;",6)
  1.  ..Q:YY=""
  1.  ..S YY=$O(^LAB(60,"B",YY,0))
  1.  ..I 'YY,$D(^LAB(60,+$P(Z,";;",5),0)),$E($P(^(0),U),1,5)=$E($P(Z,";;",6),1,5) S YY=$P(Z,";;",5)
  1.  .Q:'YY
  1.  .Q:'$D(^LAB(60,YY,0))
  1.  .S APCLDA(1)=APCLDA
  1.  .Q:$D(^ATXLAB(APCLDA,21,"B",YY))
  1.  .I '$D(ZTQUEUED) U IO W !?10,"FILE LAB ITEM: ",YY
  1.  .S X=YY
  1.  .S DA=APCLDA
  1.  .S DA(1)=APCLDA
  1.  .S DIC="^ATXLAB("_DA_",21,"
  1.  .S DIC(0)="L"
  1.  .S:'$D(^ATXLAB(DA,21,0)) ^ATXLAB(DA,21,0)="^9002228.02101PA"
  1.  .D FILE^APCLDIC
  1.  .S APCLDA(1)=+Y
  1.  I $G(APCLDA),$G(APCLDA(1)),$P(Z,";;",2)=21,$P(Z,";;",6)="SOURCE" D
  1.  .I $D(^ATXLAB(APCLDA,21,APCLDA(1))),'$D(^ATXLAB(APCLDA,21,APCLDA(1),11,$P(Z,";;",5),0)) D
  1.  ..S ^ATXLAB(APCLDA,21,APCLDA(1),11,$P(Z,";;",5),0)=$P(Z,";;",7)
  1.  ..I '$D(ZTQUEUED) U IO W !?10,"FILE LAB ITEM SOURCE: ",Z
  1.  Q