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

BLSULLF.m

Go to the documentation of this file. 
  1. BLSULLF ; IHS/CMI/LAB - ADD NEW LOINC CODES FROM REGENSTIEF ; [ 12/19/2002  7:08 AM ]
  1.  ;;5.2;LR;**1015**;NOV 18, 2002
  1.  ;
  1.  ;
  1.  ;
  1.  Q  ;NOT AT TOP
  1.  ;
  1. UPLOAD ;EP
  1.  S ADDS=0
  1.  S BLSX=0 F  S BLSX=$O(^BLSLDATA("TEMP",BLSX)) Q:BLSX'=+BLSX  D
  1.  .Q:$G(^BLSLDATA("TEMP",BLSX,35,1))'=1
  1.  .S CODE=^BLSLDATA("TEMP",BLSX,1,1)
  1.  .S V1=$P(CODE,"-")
  1.  .S BLSIEN=$O(^LAB(95.3,"B",V1,0)) I 'BLSIEN S NEWADD=1 D ADD Q
  1.  .S NEWADD=0 D EDIT
  1.  .D CU
  1.  .Q
  1.  Q
  1.  ;
  1. ADD ;
  1.  S ADDS=ADDS+1
  1.  W !,"ADDING ",CODE
  1.  D ^XBFMK K DLAYGO,DIADD
  1.  S DINUM=V1,X=V1,DIC="^LAB(95.3,",DIC(0)="L",DIADD=1
  1.  D FILE^DICN
  1.  I Y=-1 W !,"Adding new code failed ",V1 D ^XBFMK K DIADD,DLAYGO Q
  1.  S BLSIEN=+Y
  1.  K DIADD,DLAYGO,DIC,DR,DA
  1.  D ^XBFMK
  1.  D EDIT
  1.  Q
  1. L9531(V) ;
  1.  I $G(V)="" Q ""
  1.  NEW DIC,DA,DR
  1.  S Y=$O(^LAB(95.31,"CIHS",V,0)) I Y Q Y
  1.  S Y=$O(^LAB(95.31,"C",V,0)) I Y Q Y
  1.  S Y=$O(^LAB(95.31,"B",V,0)) I Y Q Y
  1.  S DIC=95.31,DIC(0)="LMX",X=V D ^DIC
  1.  I Y=-1 Q ""
  1.  S ^LAB(95.31,+Y,1)=$E(V)_$$LOW^XLFSTR($E(V,2,999))
  1.  S ^LAB(95.31,+Y,2)=$E(V)_$$LOW^XLFSTR($E(V,2,999))
  1.  ;W !,"added to 95.31 ",V
  1.  Q +Y
  1. L061(V,T) ;Lookup ien in LAB(64.061
  1.  I $G(V)="" Q ""
  1.  S T=$G(T)
  1.  NEW DIC,DA,DR
  1.  S Y=$O(^LAB(64.061,"E",V,0)) I Y Q Y
  1.  S Y=$O(^LAB(64.061,"C",$$UP^XLFSTR(V),0)) I Y Q Y
  1.  S Y=$O(^LAB(64.061,"DIHS",V,0)) I Y Q Y
  1.  S DIC=64.061,DIC(0)="MLX",X=V,DIC("DR")="7///"_$G(T) D ^DIC
  1.  I Y=-1 Q ""
  1.  S $P(^LAB(64.061,+Y,0),U,8)="from LOINC system list 1/6/2002"
  1.  ;W !,"added to 64.061 ",V
  1.  Q +Y
  1. L642(V) ;
  1.  I $G(V)="" Q ""
  1.  NEW DIC,DA,DR
  1.  S Y=$O(^LAB(64.2,"CIHS",V,0)) I Y Q Y
  1.  S DIC=64.2,DIC(0)="MLX",X=V D ^DIC
  1.  I Y=-1 Q ""
  1.  ;W !,"added to 64.2 ",V
  1.  Q +Y
  1. EDIT ;edit an existing entry
  1.  D ^XBFMK
  1.  S DR="",DIE="^LAB(95.3,",DA=BLSIEN
  1.  ;each field value is set and then DR string built
  1. F1 ;field 1, piece 1 of piece 2
  1.  S F1=$G(^BLSLDATA("TEMP",BLSX,2,1)),F1=$P(F1,"~",1)
  1.  I F1]"" D
  1.  .S F1V=$$L9531(F1) I F1V="" W !,"LOINC CODE: ",CODE," failed COMPONENT COLUMN B-1 "_F1 Q
  1.  .S DR=DR_"1////"_F1V
  1. F15 ;
  1.  S F15=$G(^BLSLDATA("TEMP",BLSX,2,1)),F15=$P(F15,"~",2)
  1.  I F15]"" D
  1.  .S F15V=$$L061(F15,"C") I F15V="" W !,"LOINC CODE: ",CODE," failed CHALLENGE COLUMN B-2 "_F15 Q
  1.  .S DR=DR_";1.5////"_F15V
  1. F16 ;field 1.6 col b piece 2
  1.  S F16=$G(^BLSLDATA("TEMP",BLSX,2,1)),F16=$P(F16,"~",3)
  1.  I F16]"" D
  1.  .S F16V=$$L061(F16,"A") I F16V="" W !,"LOINC CODE: ",CODE," failed ADJUSTMENT COLUMN B-2 "_F16 Q
  1.  .S DR=DR_";1.6////"_F16V
  1. F17 ;field 1.7 col e piece 2
  1.  S F17=$G(^BLSLDATA("TEMP",BLSX,5,1)),F17=$P(F17,"~",2)
  1.  I F17]"" D
  1.  .S F17V=$$L061(F17,"S") I F17V="" W !,"LOINC CODE: ",CODE," failed NON-PATIENT SPECIMEN COLUMN E-2 "_F17 Q
  1.  .S DR=DR_";1.7////"_F17V
  1. F2 ;
  1.  S F2=$G(^BLSLDATA("TEMP",BLSX,3,1)) I F2="-" S F2=""
  1.  I F2]"" D
  1.  .S F2V=$$L061(F2,"PR") I F2V="" W !,"LOINC CODE: ",CODE," failed PROPERTY COLUMN C ",F2 Q
  1.  .S DR=DR_";2////"_F2V
  1. F3 ;
  1.  S F3=$G(^BLSLDATA("TEMP",BLSX,4,1)),F3=$P(F3,"~",1)
  1.  I F3]"" D
  1.  .S F3V=$$L061(F3) I F3="" W !,"LOINC CODE: ",CODE," failed TIME ASPECT COLUMN D-1 ",F3 Q
  1.  .S DR=DR_";3////"_F3V
  1. F31 ;
  1.  S F31=$G(^BLSLDATA("TEMP",BLSX,4,1)),F31=$P(F31,"~",2)
  1.  I F31]"" D
  1.  .S F31V=$$L061(F31,"M") I F31V="" W !,"LOINC CODE: ",CODE," failed TIME MODIFIER COLUMN D-2 ",F31 Q
  1.  .S DR=DR_";3.1////"_F31V
  1. F4 ;
  1.  S F4=$G(^BLSLDATA("TEMP",BLSX,5,1)),F4=$P(F4,"~",1)
  1.  I F4]"" D
  1.  .S F4V=$$L061(F4) I F4V="" W !,"LOINC CODE: ",CODE," failed SYSTEM COLUMN E-1 ",F4 Q
  1.  .S DR=DR_";4////"_F4V
  1. F5 ;
  1.  S F5=$G(^BLSLDATA("TEMP",BLSX,6,1)) I F5="-" S F5=""
  1.  I F5]"" D
  1.  .S F5V=$$L061(F5) I F5V="" W !,"LOINC CODE: ",CODE," failed SCALE TYPE COLUMN F ",F5 Q
  1.  .S DR=DR_";5////"_F5V
  1. F6 ;
  1.  S F6=$G(^BLSLDATA("TEMP",BLSX,7,1)),F6=$TR(F6,"."," ") S:F6="*" F6=""
  1.  I F6]"" D
  1.  .S F6V=$$L642(F6) I F6V="" W !,"LOINC CODE: ",CODE," failed METHOD TYPE COLUMN C ",F6 Q
  1.  .S DR=DR_";6////"_F6V
  1. F7 ;
  1.  S F7=$G(^BLSLDATA("TEMP",BLSX,9,1))
  1.  I F7]"" D
  1.  .S F7V=$$L061(F7) I F7V="" W !,"LOINC CODE: ",CODE," failed CLASS COLUMN I ",F7 Q
  1.  .S DR=DR_";7////"_F7V
  1. F10 ;
  1.  S F10=$G(^BLSLDATA("TEMP",BLSX,28,1)),F10=$TR(F10,"[",""),F10=$TR(F10,"]",""),F10=$TR(F10,"{",""),F10=$TR(F10,"}",""),F10=$$TRIMLS(F10)
  1.  I F10]"" D
  1.  .S F10V=$$L061(F10) I F10V="" W !,"LOINC CODE: ",CODE," failed UNITS COLUMN AB ",F10 Q
  1.  .S DR=DR_";10////"_F10V
  1. F11 ;
  1.  S F11=$G(^BLSLDATA("TEMP",BLSX,27,1))
  1.  I F11]"" S DR=DR_";11///"_F11
  1. F13 ;
  1.  S F13=$G(^BLSLDATA("TEMP",BLSX,33,1))
  1.  I F13]"" S DR=DR_";13///"_F13
  1. F20 ;
  1.  S F20=$G(^BLSLDATA("TEMP",BLSX,19,1))
  1.  I F20]"" S DR=DR_";20///"_F20
  1. F21 ;
  1.  S F21=$G(^BLSLDATA("TEMP",BLSX,1,1)),F21=$P(F21,"-",1)
  1.  I F21]"" D
  1.  .S F21=$O(^LAB(95.3,"B",F21,0)) I F21="" W !,"LOINC CODE: ",CODE," failed MAP TO COLUMN T" Q
  1.  .S DR=DR_";21////"_F21
  1. F22 ;
  1.  S F22=$G(^BLSLDATA("TEMP",BLSX,14,1))
  1.  I F22]"" S F22=$E(F22,5,6)_"/"_$E(F22,7,8)_"/"_$E(F22,1,4),DR=DR_";22///"_F22
  1. F23 ;
  1.  S F23=$G(^BLSLDATA("TEMP",BLSX,16,1))
  1.  I F23]"" S DR=DR_";23///"_F23
  1. F30 ;
  1.  S F30=$G(^BLSLDATA("TEMP",BLSX,11,1))
  1.  I F30]"" S DR=DR_";30///"_F30
  1. F32 ;
  1.  S F32=$G(^BLSLDATA("TEMP",BLSX,13,1))
  1.  I F32]"" S DR=DR_";32///"_F32
  1. F33 ;
  1.  S F33=$G(^BLSLDATA("TEMP",BLSX,22,1))
  1.  I F33]"" S DR=DR_";33///"_F33
  1. F34 ;
  1.  S F34=$G(^BLSLDATA("TEMP",BLSX,23,1))
  1.  I F34]"" S DR=DR_";34///"_F34
  1. F35 ;
  1.  S F35=$G(^BLSLDATA("TEMP",BLSX,24,1))
  1.  I F35]"" S DR=DR_";35///"_F35
  1. F37 ;
  1.  S F37=$G(^BLSLDATA("TEMP",BLSX,26,1))
  1.  I F37]"" S DR=DR_";37///"_F37
  1. F38 ;
  1.  S F38=$G(^BLSLDATA("TEMP",BLSX,30,1))
  1.  I F38]"" S DR=DR_";38///"_F38
  1. F40 ;
  1.  S F40=$G(^BLSLDATA("TEMP",BLSX,34,1))
  1.  I F40]"" S DR=DR_";40///"_F40
  1. F50 ;
  1.  S BLSRN=$G(^BLSLDATA("TEMP",BLSX,8,1))
  1.  I BLSRN]"" D
  1.  .S L=$L(BLSRN,";")
  1.  .F Z=1:1:L S X=$P(BLSRN,";",Z) Q:X=""  S X=$$TrimAll(X) D
  1.  ..I X="" Q
  1.  ..S G=0,Y=0 F  S Y=$O(^LAB(95.3,DA,50,Y)) Q:Y'=+Y  I X=$P(^LAB(95.3,DA,50,Y,0),U) S G=1
  1.  ..Q:G
  1.  ..S (Y,NIEN)=0 F  S Y=$O(^LAB(95.3,DA,50,Y)) Q:Y'=+Y  S NIEN=Y
  1.  ..S NIEN=NIEN+1
  1.  ..S ^LAB(95.3,DA,50,NIEN,0)=X,^LAB(95.3,DA,50,"B",X,NIEN)="",$P(^LAB(95.3,DA,50,0),U,3)=NIEN,$P(^LAB(95.3,DA,50,0),U,4)=$P(^LAB(95.3,DA,50,0),U,4)+1,$P(^LAB(95.3,DA,50,0),U,2)=95.39
  1. F60 ;
  1.  S BLSAL=0 F  S BLSAL=$O(^BLSLDATA("TEMP",BLSX,18,BLSAL)) Q:BLSAL'=+BLSAL  D
  1.  .S BLSDV=^BLSLDATA("TEMP",BLSX,18,BLSAL) Q:BLSDV=""
  1.  .S X=$$TrimAll(BLSDV) D
  1.  ..S G=0,Y=0 F  S Y=$O(^LAB(95.3,DA,2,Y)) Q:Y'=+Y  I X=$P(^LAB(95.3,DA,2,Y,0),U) S G=1
  1.  ..Q:G
  1.  ..S (Y,NIEN)=0 F  S Y=$O(^LAB(95.3,DA,2,Y)) Q:Y'=+Y  S NIEN=Y
  1.  ..S NIEN=NIEN+1
  1.  ..S ^LAB(95.3,DA,2,NIEN,0)=X,^LAB(95.3,DA,2,"B",X,NIEN)="",$P(^LAB(95.3,DA,2,0),U,3)=NIEN,$P(^LAB(95.3,DA,2,0),U,4)=$P(^LAB(95.3,DA,2,0),U,4)+1,$P(^LAB(95.3,DA,2,0),U,2)=95.33
  1. F70 ;
  1.  ;NO DATA IN REG FILE
  1. F80 ;
  1.  S FULLSN=$G(^BLSLDATA("TEMP",BLSX,2,1))_":"_$G(^BLSLDATA("TEMP",BLSX,3,1))_":"_$G(^BLSLDATA("TEMP",BLSX,4,1))_":"_$G(^BLSLDATA("TEMP",BLSX,5,1))_":"_$G(^BLSLDATA("TEMP",BLSX,6,1))_":"_$G(^BLSLDATA("TEMP",BLSX,7,1))
  1.  S FULLSN=$$TRIMTC(FULLSN)
  1.  S DR=DR_";80///"_FULLSN
  1.  ;I 'NEWADD,FULLSN'=$P($G(^LAB(95.3,DA,80)),U) W !,"NOT SAME ",CODE
  1.  S DR=DR_";9999999.01///"_$P(CODE,"-",2)_";9999999.02///"_CODE
  1. F99 ;
  1.  ;leave out comments for now.  Exisiting data not fileman compatible with WP field type.
  1. DIE ;call die
  1.  D ^DIE
  1.  I $D(Y) W !,"die failed with code ",CODE," dR=",DR D ^XBFMK Q
  1.  ;
  1.  S $P(^LAB(95.3,BLSIEN,9999999),U,1)=$P(CODE,"-",2)
  1.  S $P(^LAB(95.3,BLSIEN,9999999),U,2)=CODE
  1. F24 ;
  1.  S F24=$G(^BLSLDATA("TEMP",BLSX,15,1))
  1.  I F24]"" S $P(^LAB(95.3,BLSIEN,4),U,5)=F24
  1. F36 ;
  1.  S F36=$G(^BLSLDATA("TEMP",BLSX,25,1))
  1.  I F36]"" S $P(^LAB(95.3,BLSIEN,1),U,7)=F36
  1. CU ;
  1.  K CODE,V1,F1,V22,V3,V41,V42,F1V,F2,F2V,F3,F3V,F4,F4V,F5,F5V,F6,F6V
  1.  D ^XBFMK
  1.  K DLAYGO,DIADD
  1.  Q
  1. FILE ;upload global
  1. DIR ;
  1.  S BLSDIR=""
  1.  S DIR(0)="F^2:60",DIR("A")="Enter directory path (i.e. /usr/spool/uucppublic/)" K DA D ^DIR K DIR
  1.  I $D(DIRUT) W !!,"Directory not entered!!  Bye." S BLSQUIT=1 Q
  1.  S BLSDIR=Y
  1.  S BLSFILE=""
  1.  S DIR(0)="F^2:30",DIR("A")="Enter filename w /ext (i.e. NCIDATA.TXT)" K DA D ^DIR K DIR
  1.  G:$D(DIRUT) DIR
  1.  S BLSFILE=Y
  1.  W !,"Directory=",BLSDIR,"  ","File=",BLSFILE,"  reading file into ^BLSLDATA...",!
  1. READF ;read file
  1.  NEW Y,X,I
  1.  S BLSC=0
  1.  S Y=$$OPEN^%ZISH(BLSDIR,BLSFILE,"R")
  1.  I Y W !,*7,"CANNOT OPEN (OR ACCESS) FILE '",BLSDIR,BLSFILE,"'." S BLSQUIT=1 Q
  1.  KILL ^BLSLDATA("TEMP")
  1.  F I=1:1 U IO R BLSDATA:DTIME Q:BLSDATA=""!($$STATUS^%ZISH=-1)  D LOOP
  1.  D ^%ZISC
  1.  W !!,"All done reading file",!
  1.  Q
  1. LOOP ;
  1.  S BLSC=BLSC+1
  1.  S BLSDATA=$TR(BLSDATA,$C(9),"|")
  1.  S BLSDATA=$TR(BLSDATA,"$","")
  1.  S BLSDATA=$TR(BLSDATA,"""","")
  1.  S BLSDATA=$TR(BLSDATA,"^","~")
  1.  S BLSX=BLSDATA,BLSY=$L(BLSDATA,"|")
  1.  S $P(BLSX,"|",45)="" ;THIS IS THE SYNONYMS OR SOME SUCH LONG FIELD COLUMN AT - DO NOT LOAD
  1.  F BLSZ=1:1:BLSY D
  1.  .S BLSLC=1
  1.  .I BLSZ=17 D  Q  ;handle field 17, column Q comments for WP field
  1.  ..K ^UTILITY($J,"W") S DIWL=1,DIWR=70,X=$P(BLSX,"|",17) D ^DIWP
  1.  ..S Y=0 F  S Y=$O(^UTILITY($J,"W",DIWL,Y)) Q:Y'=+Y  S ^BLSLDATA("TEMP",BLSC,BLSZ,BLSLC)=^UTILITY($J,"W",DIWL,Y,0),BLSLC=BLSLC+1
  1.  ..K DIWL,DIWR,X
  1.  ..K ^UTILITY($J,"W")
  1.  ..Q
  1.  .I BLSZ=18 S BLSLC=1 D  Q  ;handle answer back for multiple field ; pieces
  1.  ..S Y=$P(BLSX,"|",18) F Z=1:1 S Y=$P(BLSX,";",Z) Q:Y=""  S Y=$$TrimLSpc(Y),Y=$TR(Y,"^","~"),^BLSLDATA("TEMP",BLSC,BLSZ,BLSLC)=Y,BLSLC=BLSLC+1
  1.  ..Q
  1.  .I $P(BLSX,"|",BLSZ)]"" S ^BLSLDATA("TEMP",BLSC,BLSZ,BLSLC)=$P(BLSX,"|",BLSZ)
  1.  Q
  1.  ;-------------------------------------------------------------------
  1. TrimLSpc(X) ;
  1.  F  Q:$E(X,1)'=" "  S X=$E(X,2,$L(X))
  1.  Q X
  1.  ;--------------------------------------------------------------------
  1.  ;Trim Trailing Spaces
  1. TrimTSpc(X) ;
  1.  F  Q:$E(X,$L(X))'=" "  S X=$E(X,1,$L(X)-1)
  1.  Q X
  1.  ;--------------------------------------------------------------------
  1.  ;Trim All Leading and Trailing Spaces
  1. TRIMLS(X) ;
  1.  F  Q:$E(X,1)'="/"  S X=$E(X,2,$L(X))
  1.  Q X
  1.  ;--------------------------------------------------------------------
  1. TRIMTC(X) ;
  1.  F  Q:$E(X,$L(X))'=":"  S X=$E(X,1,$L(X)-1)
  1.  Q X
  1.  ;--------------------------------------------------------------------
  1.  ;Trim All Leading and Trailing Spaces
  1. TrimAll(X) ;
  1.  Q $$TrimLSpc($$TrimTSpc(X))
  1.  ;--------------------------------------------------------------------
  1.  ;Remove Extra Spaces
  1. PackStr(X) ;
  1.  F  Q:X'["  "  S X=$P(X,"  ",1)_" "_$P(X,"  ",2,9999)
  1.  Q X
  1.  ;--------------------------------------------------------------------
  1. UCase(X) ;
  1.  Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1.  ;--------------------------------------------------------------------
  1. Clean(X) ;
  1.  Q $$UCase($$TrimAll(X))
  1.  ;--------------------------------------------------------------------