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