LR469A ;DSS/TFF - LAB ANATOMIC PATHOLOGY INSTALLATION SUPPORT;03/04/16 12:21 ;08/12/16 11:25
;;5.2;LAB SERVICE;**469**;Feb 14, 1996;Build 19
;
;
;
;
ENV ; Environment Check
D ENVT W ! D ENVS
I '$$FIND1^DIC(62,,"X","AP SPECIMEN") S XPDQUIT=1 D
. W !!," *********************** AP SPECIMEN ***********************"
. W !," * COLLECTION SAMPLE (File 62) 'AP SPECIMEN' is missing! *"
. W !," *********************** AP SPECIMEN ***********************"
Q
;
ENVT ; Environment Check Orderable Items
N I,STR,NAM,IEN,SUCCS
F I=1:1 S STR=$P($T(TTEST+I),";;",2) Q:STR="" D
. S NAM=$$UP^XLFSTR($P(STR,";",2))
. I '$D(^ORD(101.43,"B",NAM)) S XPDQUIT=1 D Q
. . W !," *** There is no ORDERABLE ITEM with the name '"_NAM_"'"
. S (IEN,SUCCS)=0 F S IEN=$O(^ORD(101.43,"B",NAM,IEN)) Q:'IEN D
. . Q:$$UP^XLFSTR($P($G(^ORD(101.43,IEN,0)),U))'=NAM
. . Q:$$UP^XLFSTR($$GET1^DIQ(101.43,IEN_",",5))'="ANATOMIC PATHOLOGY"
. . S SUCCS=SUCCS+1
. I SUCCS>1 S XPDQUIT=1 D Q
. . W !," *** ORDERABLE ITEM '"_NAM_"' exists but there are multiple entries"
. I 'SUCCS S XPDQUIT=1 D Q
. . W !," *** There is no ORDERABLE ITEM '"_NAM_"' within the ANATOMIC PATHOLOGY display group"
. I SUCCS W !," Found ORDERABLE ITEM '"_NAM_"'"
Q
;
ENVS ; Enviroment Check Specimen
N I,STR,NAM,CODE,SPEC,IEN,SUCCS
F I=1:1 S STR=$P($T(TSPEC+I),";;",2) Q:STR="" D
. S NAM=$$UP^XLFSTR($P(STR,";",2)),CODE=$P(STR,";",3)
. I CODE="" S XPDQUIT=1 D Q
. . W !!," *** '"_NAM_"'",!,?10,"SNOMED CT for SPECIMEN not provided for '"_NAM_"'"
. I '$D(^LAB(61,"F",CODE)) S XPDQUIT=1 D Q
. . W !!," *** '"_NAM_"'",!,?10,"SNOMED CT '"_CODE_"' has not been assigned to a SPECIMEN"
. K SPEC S (IEN,SUCCS)=0 F S IEN=$O(^LAB(61,"F",CODE,IEN)) Q:'IEN D
. . S SPEC(IEN)=$$UP^XLFSTR($P($G(^LAB(61,IEN,0)),U)),SUCCS=SUCCS+1
. I SUCCS>1 D Q
. . S (IEN,SUCCS)=0 F S IEN=$O(SPEC(IEN)) Q:'IEN D
. . . I SPEC(IEN)=NAM S SUCCS=SUCCS+1
. . I SUCCS'=1 S XPDQUIT=1 D Q
. . . W !!," *** '"_NAM_"'",!,?10,"Multiple matches for SNOMED CT '"_CODE_"' with "
. . . W $S(SUCCS>1:"same name matches",1:"no name match")
. . W !!," *** '"_NAM_"'",!,?10,"Found SPECIMEN for SNOMED CT '"_CODE_"' and name '"_NAM_"'"
. W !!," *** '"_NAM_"'",!,?10,"Found SPECIMEN for SNOMED CT '"_CODE_"'"
Q
;
POST ; Post Install - REBUILD THE AP DIALOG DATA
N I,STR,IEN,NAM,S,SIEN,SCODE,SNAM,DIK
F I=1:1 S STR=$P($T(TTEST+I),";;",2) Q:STR="" D
. S IEN=$P(STR,";"),NAM=$$UP^XLFSTR($P(STR,";",2))
. I IEN'=$$FIND1("TTEST",NAM) S IEN=$$TEST(IEN,NAM)
. I IEN F S=1:1 S STR=$P($T(TSPEC+S),";;",2) Q:STR="" D
. . S SIEN=$P(STR,";"),SNAM=$$UP^XLFSTR($P(STR,";",2)),SCODE=$P(STR,";",3)
. . I SIEN'=$$FIND1("TSPEC",SNAM,SCODE) D SPEC(IEN,SIEN,SNAM,SCODE)
; *** ReIndex
K ^LAB(69.73,"B")
S DIK="^LAB(69.73," D IXALL2^DIK,IXALL^DIK
Q
;
TEST(IEN,NAM) ; Get/Set the old global entry
Q:'$D(^LAB(69.73,IEN)) 0
N NEW,CT,STR,CAP
S NEW=$$FIND1("TTEST",NAM) I NEW D
. S CT=$NA(^LAB(69.73,IEN)) F S CT=$Q(@CT) Q:CT="" Q:$QS(CT,1)'=69.73!($QS(CT,2)'=IEN) D
. . S STR=CT,$P(STR,",",2)=NEW
. . S CAP(STR)=@CT
. . I $QL(CT)=3,$QS(CT,3)=0 S CAP(STR)=NEW
K ^LAB(69.73,IEN)
Q:'$D(CAP) IEN
S CT="" F S CT=$O(CAP(CT)) Q:CT="" S:$E(CT,1,11)="^LAB(69.73," @CT=CAP(CT)
Q NEW
;
SPEC(IEN,SPC,NAM,CODE) ; Get the old global sub entry for specimen
N NEW,CT,STR,CAP
S NEW=$$FIND1("TSPEC",NAM,CODE) I NEW D
. S CT=$NA(^LAB(69.73,IEN,3,SPC)) F S CT=$Q(@CT) Q:CT="" Q:$QS(CT,1)'=69.73!($QS(CT,2)'=IEN)!($QS(CT,3)'=3)!($QS(CT,4)'=SPC) D
. . S STR=CT,$P(STR,",",4)=NEW
. . S CAP(STR)=@CT
. . I $QL(CT)=5,$QS(CT,5)=0 S CAP(STR)=NEW
Q:'$D(CAP)
K ^LAB(69.73,IEN,3,SPC)
S CT="" F S CT=$O(CAP(CT)) Q:CT="" S:$E(CT,1,11+$L(IEN))="^LAB(69.73,"_IEN @CT=CAP(CT)
Q
;
FIND1(TAG,NAM,CODE) ; Lookup
N CT,IEN,SUCCS,SPEC
S NAM=$$UP^XLFSTR($G(NAM)),CODE=$G(CODE),SUCCS=0
I TAG="TTEST" D
. Q:'$D(^ORD(101.43,"B",NAM))
. S (CT,IEN)=0 F S CT=$O(^ORD(101.43,"B",NAM,CT)) Q:'CT D
. . Q:$$UP^XLFSTR($P($G(^ORD(101.43,CT,0)),U))'=NAM
. . Q:$$UP^XLFSTR($$GET1^DIQ(101.43,CT_",",5))'="ANATOMIC PATHOLOGY"
. . S SUCCS=SUCCS+1,IEN=CT
I TAG="TSPEC" D
. Q:CODE=""
. K SPEC S (CT,SUCCS)=0 F S CT=$O(^LAB(61,"F",CODE,CT)) Q:'CT D
. . S SPEC(CT)=$$UP^XLFSTR($P($G(^LAB(61,CT,0)),U)),SUCCS=SUCCS+1,IEN=CT
. I SUCCS>1 D Q
. . S (CT,SUCCS,IEN)=0 F S CT=$O(SPEC(CT)) Q:'CT D
. . . I SPEC(CT)=NAM S SUCCS=SUCCS+1,IEN=CT
. . I SUCCS>1 S IEN=0
Q $S(SUCCS'=1:0,$G(IEN):IEN,1:0)
;
BUILD ; Build the Transport Routine Text
N ND,SP,SPEC
I '$D(^LAB(69.73,"B")) W !,"***** No configuration to print. *****",! Q
W !,"TTEST ; Dialog data to convert",!
S ND=0 F S ND=$O(^LAB(69.73,"B",ND)) Q:'ND D
. W " ;;",ND,";",$P($G(^ORD(101.43,ND,0)),U),!
W " ;;",!," Q",!," ;",!
W "TSPEC ; Specimen data to convert",!
S ND=$NA(^LAB(69.73)) F S ND=$Q(@ND) Q:ND="" Q:$QS(ND,1)'=69.73 D
. I $QS(ND,3)=3,$QS(ND,5)=0 D
. . S SP=$P($G(^LAB(61,+$P(@ND,U),0)),U) I SP'="" D
. . . S SPEC(SP)=+$P(@ND,U)_";"_SP_";"_$$GET1^DIQ(61,+$P(@ND,U)_",",20)
I $D(SPEC) S SP="" F S SP=$O(SPEC(SP)) Q:SP="" W " ;;",SPEC(SP),!
W " ;;",!," Q",!
Q
;
; ******** RUN BUILD ABOVE AND UPDATE BELOW THIS LINE WITH THE OUTPUT ********
;
TTEST ; Dialog data to convert
;;766;BONE MARROW
;;4968;BRONCHIAL BIOPSY
;;4969;BRONCHIAL CYTOLOGY
;;4970;DERMATOLOGY
;;4971;FINE NEEDLE ASPIRATE
;;4972;GASTROINTESTINAL ENDOSCOPY
;;4974;GENERAL FLUID
;;4975;GYNECOLOGY (PAP SMEAR)
;;4976;TISSUE EXAM
;;4977;UROLOGY,BLADDER/URETER
;;4978;UROLOGY,PROSTATE
;;4979;RENAL BIOPSY
;;4980;URINE
;;
Q
;
TSPEC ; Specimen data to convert
;;114;ABDOMEN;113345001
;;23;ADRENAL GLAND;23451007
;;5451;ANAL CANAL;34381000
;;66;APPENDIX;66754008
;;5401;ASCENDING COLON;9040008
;;5137;BILE DUCT CYTOLOGIC MATERIAL;110928002
;;5079;BILE DUCT MUCOUS MEMBRANE;7035006
;;4707;BILIARY TRACT;34707002
;;5117;BODY OF PANCREAS;40133006
;;322;BONE;3138006
;;319;BONE MARROW;14016003
;;318;BREAST;76752008
;;3533;BRONCHIAL CYTOLOGIC MATERIAL;110912007
;;336;BRONCHUS;955009
;;5248;CARDIAC INCISURE OF STOMACH;5459006
;;5246;CARDIAC OSTIUM OF STOMACH;63853002
;;5205;CARDIO-ESOPHAGEAL JUNCTION;25271004
;;231;CECUM;32713005
;;6464;CEREBROSPINAL FLUID CYTOLOGIC MATERIAL;110969006
;;6242;CERVICAL CYTOLOGIC MATERIAL;110949001
;;6079;CHORIONIC VILLI;2049008
;;67;COLON;71854001
;;5405;DESCENDING COLON;32622004
;;64;DUODENUM;38848004
;;62;ESOPHAGUS;32849002
;;5204;ESOPHAGUS, LOWER THIRD;67173009
;;5202;ESOPHAGUS, MIDDLE THIRD;19000002
;;5200;ESOPHAGUS, UPPER THIRD;54738009
;;5247;GASTRIC FUNDUS;414003
;;5482;GASTRIC JUICE;31773000
;;5241;GREATER CURVATURE OF STOMACH;89382009
;;5114;HEAD OF PANCREAS;64163001
;;5336;ILEUM;34516001
;;5329;JEJUNUM;21306003
;;22;KIDNEY;64033007
;;5404;LEFT COLIC FLEXURE;72592005
;;17;LEFT TESTIS;63239009
;;5239;LESSER CURVATURE OF STOMACH;80085006
;;56;LIVER;10200004
;;21;LUNG;39607008
;;213;LYMPH NODE;59441001
;;172;MEDIASTINUM;72410000
;;8310;NECK, LEFT SIDE;170583000
;;8309;NECK, RIGHT SIDE;170303002
;;4;PANCREAS;15776009
;;4946;PAROTID GLAND;45289007
;;116;PELVIS;12921003
;;3758;PERICARDIAL CYTOLOGIC MATERIAL;110919003
;;5569;PERIRENAL TISSUE;47145004
;;5504;PERITONEAL CYTOLOGIC MATERIAL;110944006
;;171;PERITONEUM;15425007
;;3561;PLEURAL CYTOLOGIC MATERIAL;110913002
;;15;PROSTATE;41216001
;;5252;PYLORIC ANTRUM;66051006
;;5254;PYLORUS;280119005
;;5443;RECTOSIGMOID JUNCTION;49832006
;;68;RECTUM;34402009
;;186;RENAL PELVIS;25990002
;;143;RETROPERITONEUM;82849001
;;5402;RIGHT COLIC FLEXURE;48338005
;;16;RIGHT TESTIS;15598003
;;55;SALIVARY GLAND;385294005
;;5406;SIGMOID COLON;60184004
;;315;SKIN;39937001
;;5273;SMALL INTESTINE;30315005
;;314;SOFT TISSUES;87784001
;;3;SPLEEN;78961009
;;63;STOMACH;69695003
;;4960;SUBLINGUAL GLAND;88481005
;;4968;SUBMAXILLARY GLAND;54019009
;;8433;SUBPHRENIC FOSSA;243974009
;;3117;SYNOVIAL CYTOLOGIC MATERIAL;110895009
;;5125;TAIL OF PANCREAS;73239005
;;5;THYROID GLAND;69748006
;;8729;TISSUE;85756007
;;5403;TRANSVERSE COLON;485005
;;351;URETER;87953007
;;87;URINARY BLADDER;89837001
;;71;URINE;78014005
;;234;VAS DEFERENS;57671007
;;189;VERTEBRA;51282000
;;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR469A 8386 printed Dec 13, 2024@02:04:07 Page 2
LR469A ;DSS/TFF - LAB ANATOMIC PATHOLOGY INSTALLATION SUPPORT;03/04/16 12:21 ;08/12/16 11:25
+1 ;;5.2;LAB SERVICE;**469**;Feb 14, 1996;Build 19
+2 ;
+3 ;
+4 ;
+5 ;
ENV ; Environment Check
+1 DO ENVT
WRITE !
DO ENVS
+2 IF '$$FIND1^DIC(62,,"X","AP SPECIMEN")
SET XPDQUIT=1
Begin DoDot:1
+3 WRITE !!," *********************** AP SPECIMEN ***********************"
+4 WRITE !," * COLLECTION SAMPLE (File 62) 'AP SPECIMEN' is missing! *"
+5 WRITE !," *********************** AP SPECIMEN ***********************"
End DoDot:1
+6 QUIT
+7 ;
ENVT ; Environment Check Orderable Items
+1 NEW I,STR,NAM,IEN,SUCCS
+2 FOR I=1:1
SET STR=$PIECE($TEXT(TTEST+I),";;",2)
if STR=""
QUIT
Begin DoDot:1
+3 SET NAM=$$UP^XLFSTR($PIECE(STR,";",2))
+4 IF '$DATA(^ORD(101.43,"B",NAM))
SET XPDQUIT=1
Begin DoDot:2
+5 WRITE !," *** There is no ORDERABLE ITEM with the name '"_NAM_"'"
End DoDot:2
QUIT
+6 SET (IEN,SUCCS)=0
FOR
SET IEN=$ORDER(^ORD(101.43,"B",NAM,IEN))
if 'IEN
QUIT
Begin DoDot:2
+7 if $$UP^XLFSTR($PIECE($GET(^ORD(101.43,IEN,0)),U))'=NAM
QUIT
+8 if $$UP^XLFSTR($$GET1^DIQ(101.43,IEN_",",5))'="ANATOMIC PATHOLOGY"
QUIT
+9 SET SUCCS=SUCCS+1
End DoDot:2
+10 IF SUCCS>1
SET XPDQUIT=1
Begin DoDot:2
+11 WRITE !," *** ORDERABLE ITEM '"_NAM_"' exists but there are multiple entries"
End DoDot:2
QUIT
+12 IF 'SUCCS
SET XPDQUIT=1
Begin DoDot:2
+13 WRITE !," *** There is no ORDERABLE ITEM '"_NAM_"' within the ANATOMIC PATHOLOGY display group"
End DoDot:2
QUIT
+14 IF SUCCS
WRITE !," Found ORDERABLE ITEM '"_NAM_"'"
End DoDot:1
+15 QUIT
+16 ;
ENVS ; Enviroment Check Specimen
+1 NEW I,STR,NAM,CODE,SPEC,IEN,SUCCS
+2 FOR I=1:1
SET STR=$PIECE($TEXT(TSPEC+I),";;",2)
if STR=""
QUIT
Begin DoDot:1
+3 SET NAM=$$UP^XLFSTR($PIECE(STR,";",2))
SET CODE=$PIECE(STR,";",3)
+4 IF CODE=""
SET XPDQUIT=1
Begin DoDot:2
+5 WRITE !!," *** '"_NAM_"'",!,?10,"SNOMED CT for SPECIMEN not provided for '"_NAM_"'"
End DoDot:2
QUIT
+6 IF '$DATA(^LAB(61,"F",CODE))
SET XPDQUIT=1
Begin DoDot:2
+7 WRITE !!," *** '"_NAM_"'",!,?10,"SNOMED CT '"_CODE_"' has not been assigned to a SPECIMEN"
End DoDot:2
QUIT
+8 KILL SPEC
SET (IEN,SUCCS)=0
FOR
SET IEN=$ORDER(^LAB(61,"F",CODE,IEN))
if 'IEN
QUIT
Begin DoDot:2
+9 SET SPEC(IEN)=$$UP^XLFSTR($PIECE($GET(^LAB(61,IEN,0)),U))
SET SUCCS=SUCCS+1
End DoDot:2
+10 IF SUCCS>1
Begin DoDot:2
+11 SET (IEN,SUCCS)=0
FOR
SET IEN=$ORDER(SPEC(IEN))
if 'IEN
QUIT
Begin DoDot:3
+12 IF SPEC(IEN)=NAM
SET SUCCS=SUCCS+1
End DoDot:3
+13 IF SUCCS'=1
SET XPDQUIT=1
Begin DoDot:3
+14 WRITE !!," *** '"_NAM_"'",!,?10,"Multiple matches for SNOMED CT '"_CODE_"' with "
+15 WRITE $SELECT(SUCCS>1:"same name matches",1:"no name match")
End DoDot:3
QUIT
+16 WRITE !!," *** '"_NAM_"'",!,?10,"Found SPECIMEN for SNOMED CT '"_CODE_"' and name '"_NAM_"'"
End DoDot:2
QUIT
+17 WRITE !!," *** '"_NAM_"'",!,?10,"Found SPECIMEN for SNOMED CT '"_CODE_"'"
End DoDot:1
+18 QUIT
+19 ;
POST ; Post Install - REBUILD THE AP DIALOG DATA
+1 NEW I,STR,IEN,NAM,S,SIEN,SCODE,SNAM,DIK
+2 FOR I=1:1
SET STR=$PIECE($TEXT(TTEST+I),";;",2)
if STR=""
QUIT
Begin DoDot:1
+3 SET IEN=$PIECE(STR,";")
SET NAM=$$UP^XLFSTR($PIECE(STR,";",2))
+4 IF IEN'=$$FIND1("TTEST",NAM)
SET IEN=$$TEST(IEN,NAM)
+5 IF IEN
FOR S=1:1
SET STR=$PIECE($TEXT(TSPEC+S),";;",2)
if STR=""
QUIT
Begin DoDot:2
+6 SET SIEN=$PIECE(STR,";")
SET SNAM=$$UP^XLFSTR($PIECE(STR,";",2))
SET SCODE=$PIECE(STR,";",3)
+7 IF SIEN'=$$FIND1("TSPEC",SNAM,SCODE)
DO SPEC(IEN,SIEN,SNAM,SCODE)
End DoDot:2
End DoDot:1
+8 ; *** ReIndex
+9 KILL ^LAB(69.73,"B")
+10 SET DIK="^LAB(69.73,"
DO IXALL2^DIK
DO IXALL^DIK
+11 QUIT
+12 ;
TEST(IEN,NAM) ; Get/Set the old global entry
+1 if '$DATA(^LAB(69.73,IEN))
QUIT 0
+2 NEW NEW,CT,STR,CAP
+3 SET NEW=$$FIND1("TTEST",NAM)
IF NEW
Begin DoDot:1
+4 SET CT=$NAME(^LAB(69.73,IEN))
FOR
SET CT=$QUERY(@CT)
if CT=""
QUIT
if $QSUBSCRIPT(CT,1)'=69.73!($QSUBSCRIPT(CT,2)'=IEN)
QUIT
Begin DoDot:2
+5 SET STR=CT
SET $PIECE(STR,",",2)=NEW
+6 SET CAP(STR)=@CT
+7 IF $QLENGTH(CT)=3
IF $QSUBSCRIPT(CT,3)=0
SET CAP(STR)=NEW
End DoDot:2
End DoDot:1
+8 KILL ^LAB(69.73,IEN)
+9 if '$DATA(CAP)
QUIT IEN
+10 SET CT=""
FOR
SET CT=$ORDER(CAP(CT))
if CT=""
QUIT
if $EXTRACT(CT,1,11)="^LAB(69.73,"
SET @CT=CAP(CT)
+11 QUIT NEW
+12 ;
SPEC(IEN,SPC,NAM,CODE) ; Get the old global sub entry for specimen
+1 NEW NEW,CT,STR,CAP
+2 SET NEW=$$FIND1("TSPEC",NAM,CODE)
IF NEW
Begin DoDot:1
+3 SET CT=$NAME(^LAB(69.73,IEN,3,SPC))
FOR
SET CT=$QUERY(@CT)
if CT=""
QUIT
if $QSUBSCRIPT(CT,1)'=69.73!($QSUBSCRIPT(CT,2)'=IEN)!($QSUBSCRIPT(CT,3)'=3)!($QSUBSCRIPT(CT,4)'=SPC)
QUIT
Begin DoDot:2
+4 SET STR=CT
SET $PIECE(STR,",",4)=NEW
+5 SET CAP(STR)=@CT
+6 IF $QLENGTH(CT)=5
IF $QSUBSCRIPT(CT,5)=0
SET CAP(STR)=NEW
End DoDot:2
End DoDot:1
+7 if '$DATA(CAP)
QUIT
+8 KILL ^LAB(69.73,IEN,3,SPC)
+9 SET CT=""
FOR
SET CT=$ORDER(CAP(CT))
if CT=""
QUIT
if $EXTRACT(CT,1,11+$LENGTH(IEN))="^LAB(69.73,"_IEN
SET @CT=CAP(CT)
+10 QUIT
+11 ;
FIND1(TAG,NAM,CODE) ; Lookup
+1 NEW CT,IEN,SUCCS,SPEC
+2 SET NAM=$$UP^XLFSTR($GET(NAM))
SET CODE=$GET(CODE)
SET SUCCS=0
+3 IF TAG="TTEST"
Begin DoDot:1
+4 if '$DATA(^ORD(101.43,"B",NAM))
QUIT
+5 SET (CT,IEN)=0
FOR
SET CT=$ORDER(^ORD(101.43,"B",NAM,CT))
if 'CT
QUIT
Begin DoDot:2
+6 if $$UP^XLFSTR($PIECE($GET(^ORD(101.43,CT,0)),U))'=NAM
QUIT
+7 if $$UP^XLFSTR($$GET1^DIQ(101.43,CT_",",5))'="ANATOMIC PATHOLOGY"
QUIT
+8 SET SUCCS=SUCCS+1
SET IEN=CT
End DoDot:2
End DoDot:1
+9 IF TAG="TSPEC"
Begin DoDot:1
+10 if CODE=""
QUIT
+11 KILL SPEC
SET (CT,SUCCS)=0
FOR
SET CT=$ORDER(^LAB(61,"F",CODE,CT))
if 'CT
QUIT
Begin DoDot:2
+12 SET SPEC(CT)=$$UP^XLFSTR($PIECE($GET(^LAB(61,CT,0)),U))
SET SUCCS=SUCCS+1
SET IEN=CT
End DoDot:2
+13 IF SUCCS>1
Begin DoDot:2
+14 SET (CT,SUCCS,IEN)=0
FOR
SET CT=$ORDER(SPEC(CT))
if 'CT
QUIT
Begin DoDot:3
+15 IF SPEC(CT)=NAM
SET SUCCS=SUCCS+1
SET IEN=CT
End DoDot:3
+16 IF SUCCS>1
SET IEN=0
End DoDot:2
QUIT
End DoDot:1
+17 QUIT $SELECT(SUCCS'=1:0,$GET(IEN):IEN,1:0)
+18 ;
BUILD ; Build the Transport Routine Text
+1 NEW ND,SP,SPEC
+2 IF '$DATA(^LAB(69.73,"B"))
WRITE !,"***** No configuration to print. *****",!
QUIT
+3 WRITE !,"TTEST ; Dialog data to convert",!
+4 SET ND=0
FOR
SET ND=$ORDER(^LAB(69.73,"B",ND))
if 'ND
QUIT
Begin DoDot:1
+5 WRITE " ;;",ND,";",$PIECE($GET(^ORD(101.43,ND,0)),U),!
End DoDot:1
+6 WRITE " ;;",!," Q",!," ;",!
+7 WRITE "TSPEC ; Specimen data to convert",!
+8 SET ND=$NAME(^LAB(69.73))
FOR
SET ND=$QUERY(@ND)
if ND=""
QUIT
if $QSUBSCRIPT(ND,1)'=69.73
QUIT
Begin DoDot:1
+9 IF $QSUBSCRIPT(ND,3)=3
IF $QSUBSCRIPT(ND,5)=0
Begin DoDot:2
+10 SET SP=$PIECE($GET(^LAB(61,+$PIECE(@ND,U),0)),U)
IF SP'=""
Begin DoDot:3
+11 SET SPEC(SP)=+$PIECE(@ND,U)_";"_SP_";"_$$GET1^DIQ(61,+$PIECE(@ND,U)_",",20)
End DoDot:3
End DoDot:2
End DoDot:1
+12 IF $DATA(SPEC)
SET SP=""
FOR
SET SP=$ORDER(SPEC(SP))
if SP=""
QUIT
WRITE " ;;",SPEC(SP),!
+13 WRITE " ;;",!," Q",!
+14 QUIT
+15 ;
+16 ; ******** RUN BUILD ABOVE AND UPDATE BELOW THIS LINE WITH THE OUTPUT ********
+17 ;
TTEST ; Dialog data to convert
+1 ;;766;BONE MARROW
+2 ;;4968;BRONCHIAL BIOPSY
+3 ;;4969;BRONCHIAL CYTOLOGY
+4 ;;4970;DERMATOLOGY
+5 ;;4971;FINE NEEDLE ASPIRATE
+6 ;;4972;GASTROINTESTINAL ENDOSCOPY
+7 ;;4974;GENERAL FLUID
+8 ;;4975;GYNECOLOGY (PAP SMEAR)
+9 ;;4976;TISSUE EXAM
+10 ;;4977;UROLOGY,BLADDER/URETER
+11 ;;4978;UROLOGY,PROSTATE
+12 ;;4979;RENAL BIOPSY
+13 ;;4980;URINE
+14 ;;
+15 QUIT
+16 ;
TSPEC ; Specimen data to convert
+1 ;;114;ABDOMEN;113345001
+2 ;;23;ADRENAL GLAND;23451007
+3 ;;5451;ANAL CANAL;34381000
+4 ;;66;APPENDIX;66754008
+5 ;;5401;ASCENDING COLON;9040008
+6 ;;5137;BILE DUCT CYTOLOGIC MATERIAL;110928002
+7 ;;5079;BILE DUCT MUCOUS MEMBRANE;7035006
+8 ;;4707;BILIARY TRACT;34707002
+9 ;;5117;BODY OF PANCREAS;40133006
+10 ;;322;BONE;3138006
+11 ;;319;BONE MARROW;14016003
+12 ;;318;BREAST;76752008
+13 ;;3533;BRONCHIAL CYTOLOGIC MATERIAL;110912007
+14 ;;336;BRONCHUS;955009
+15 ;;5248;CARDIAC INCISURE OF STOMACH;5459006
+16 ;;5246;CARDIAC OSTIUM OF STOMACH;63853002
+17 ;;5205;CARDIO-ESOPHAGEAL JUNCTION;25271004
+18 ;;231;CECUM;32713005
+19 ;;6464;CEREBROSPINAL FLUID CYTOLOGIC MATERIAL;110969006
+20 ;;6242;CERVICAL CYTOLOGIC MATERIAL;110949001
+21 ;;6079;CHORIONIC VILLI;2049008
+22 ;;67;COLON;71854001
+23 ;;5405;DESCENDING COLON;32622004
+24 ;;64;DUODENUM;38848004
+25 ;;62;ESOPHAGUS;32849002
+26 ;;5204;ESOPHAGUS, LOWER THIRD;67173009
+27 ;;5202;ESOPHAGUS, MIDDLE THIRD;19000002
+28 ;;5200;ESOPHAGUS, UPPER THIRD;54738009
+29 ;;5247;GASTRIC FUNDUS;414003
+30 ;;5482;GASTRIC JUICE;31773000
+31 ;;5241;GREATER CURVATURE OF STOMACH;89382009
+32 ;;5114;HEAD OF PANCREAS;64163001
+33 ;;5336;ILEUM;34516001
+34 ;;5329;JEJUNUM;21306003
+35 ;;22;KIDNEY;64033007
+36 ;;5404;LEFT COLIC FLEXURE;72592005
+37 ;;17;LEFT TESTIS;63239009
+38 ;;5239;LESSER CURVATURE OF STOMACH;80085006
+39 ;;56;LIVER;10200004
+40 ;;21;LUNG;39607008
+41 ;;213;LYMPH NODE;59441001
+42 ;;172;MEDIASTINUM;72410000
+43 ;;8310;NECK, LEFT SIDE;170583000
+44 ;;8309;NECK, RIGHT SIDE;170303002
+45 ;;4;PANCREAS;15776009
+46 ;;4946;PAROTID GLAND;45289007
+47 ;;116;PELVIS;12921003
+48 ;;3758;PERICARDIAL CYTOLOGIC MATERIAL;110919003
+49 ;;5569;PERIRENAL TISSUE;47145004
+50 ;;5504;PERITONEAL CYTOLOGIC MATERIAL;110944006
+51 ;;171;PERITONEUM;15425007
+52 ;;3561;PLEURAL CYTOLOGIC MATERIAL;110913002
+53 ;;15;PROSTATE;41216001
+54 ;;5252;PYLORIC ANTRUM;66051006
+55 ;;5254;PYLORUS;280119005
+56 ;;5443;RECTOSIGMOID JUNCTION;49832006
+57 ;;68;RECTUM;34402009
+58 ;;186;RENAL PELVIS;25990002
+59 ;;143;RETROPERITONEUM;82849001
+60 ;;5402;RIGHT COLIC FLEXURE;48338005
+61 ;;16;RIGHT TESTIS;15598003
+62 ;;55;SALIVARY GLAND;385294005
+63 ;;5406;SIGMOID COLON;60184004
+64 ;;315;SKIN;39937001
+65 ;;5273;SMALL INTESTINE;30315005
+66 ;;314;SOFT TISSUES;87784001
+67 ;;3;SPLEEN;78961009
+68 ;;63;STOMACH;69695003
+69 ;;4960;SUBLINGUAL GLAND;88481005
+70 ;;4968;SUBMAXILLARY GLAND;54019009
+71 ;;8433;SUBPHRENIC FOSSA;243974009
+72 ;;3117;SYNOVIAL CYTOLOGIC MATERIAL;110895009
+73 ;;5125;TAIL OF PANCREAS;73239005
+74 ;;5;THYROID GLAND;69748006
+75 ;;8729;TISSUE;85756007
+76 ;;5403;TRANSVERSE COLON;485005
+77 ;;351;URETER;87953007
+78 ;;87;URINARY BLADDER;89837001
+79 ;;71;URINE;78014005
+80 ;;234;VAS DEFERENS;57671007
+81 ;;189;VERTEBRA;51282000
+82 ;;
+83 QUIT
