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

LR469A.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ;
  1.  ;
  1.  ;
  1. ENV ; Environment Check
  1.  D ENVT W ! D ENVS
  1.  I '$$FIND1^DIC(62,,"X","AP SPECIMEN") S XPDQUIT=1 D
  1.  . W !!,"        *********************** AP SPECIMEN ***********************"
  1.  . W !,"        *  COLLECTION SAMPLE (File 62) 'AP SPECIMEN' is missing!  *"
  1.  . W !,"        *********************** AP SPECIMEN ***********************"
  1.  Q
  1.  ;
  1. ENVT ; Environment Check Orderable Items
  1.  N I,STR,NAM,IEN,SUCCS
  1.  F I=1:1 S STR=$P($T(TTEST+I),";;",2) Q:STR=""  D
  1.  . S NAM=$$UP^XLFSTR($P(STR,";",2))
  1.  . I '$D(^ORD(101.43,"B",NAM)) S XPDQUIT=1 D  Q
  1.  . . W !,"   *** There is no ORDERABLE ITEM with the name '"_NAM_"'"
  1.  . S (IEN,SUCCS)=0 F  S IEN=$O(^ORD(101.43,"B",NAM,IEN)) Q:'IEN  D
  1.  . . Q:$$UP^XLFSTR($P($G(^ORD(101.43,IEN,0)),U))'=NAM
  1.  . . Q:$$UP^XLFSTR($$GET1^DIQ(101.43,IEN_",",5))'="ANATOMIC PATHOLOGY"
  1.  . . S SUCCS=SUCCS+1
  1.  . I SUCCS>1 S XPDQUIT=1 D  Q
  1.  . . W !,"   *** ORDERABLE ITEM '"_NAM_"' exists but there are multiple entries"
  1.  . I 'SUCCS S XPDQUIT=1 D  Q
  1.  . . W !,"   *** There is no ORDERABLE ITEM '"_NAM_"' within the ANATOMIC PATHOLOGY display group"
  1.  . I SUCCS W !,"   Found ORDERABLE ITEM '"_NAM_"'"
  1.  Q
  1.  ;
  1. ENVS ; Enviroment Check Specimen
  1.  N I,STR,NAM,CODE,SPEC,IEN,SUCCS
  1.  F I=1:1 S STR=$P($T(TSPEC+I),";;",2) Q:STR=""  D
  1.  . S NAM=$$UP^XLFSTR($P(STR,";",2)),CODE=$P(STR,";",3)
  1.  . I CODE="" S XPDQUIT=1 D  Q
  1.  . . W !!,"   *** '"_NAM_"'",!,?10,"SNOMED CT for SPECIMEN not provided for '"_NAM_"'"
  1.  . I '$D(^LAB(61,"F",CODE)) S XPDQUIT=1 D  Q
  1.  . . W !!,"   *** '"_NAM_"'",!,?10,"SNOMED CT '"_CODE_"' has not been assigned to a SPECIMEN"
  1.  . K SPEC S (IEN,SUCCS)=0 F  S IEN=$O(^LAB(61,"F",CODE,IEN)) Q:'IEN  D
  1.  . . S SPEC(IEN)=$$UP^XLFSTR($P($G(^LAB(61,IEN,0)),U)),SUCCS=SUCCS+1
  1.  . I SUCCS>1 D  Q
  1.  . . S (IEN,SUCCS)=0 F  S IEN=$O(SPEC(IEN)) Q:'IEN  D
  1.  . . . I SPEC(IEN)=NAM S SUCCS=SUCCS+1
  1.  . . I SUCCS'=1 S XPDQUIT=1 D  Q
  1.  . . . W !!,"   *** '"_NAM_"'",!,?10,"Multiple matches for SNOMED CT '"_CODE_"' with "
  1.  . . . W $S(SUCCS>1:"same name matches",1:"no name match")
  1.  . . W !!,"   *** '"_NAM_"'",!,?10,"Found SPECIMEN for SNOMED CT '"_CODE_"' and name '"_NAM_"'"
  1.  . W !!,"   *** '"_NAM_"'",!,?10,"Found SPECIMEN for SNOMED CT '"_CODE_"'"
  1.  Q
  1.  ;
  1. POST ; Post Install - REBUILD THE AP DIALOG DATA
  1.  N I,STR,IEN,NAM,S,SIEN,SCODE,SNAM,DIK
  1.  F I=1:1 S STR=$P($T(TTEST+I),";;",2) Q:STR=""  D
  1.  . S IEN=$P(STR,";"),NAM=$$UP^XLFSTR($P(STR,";",2))
  1.  . I IEN'=$$FIND1("TTEST",NAM) S IEN=$$TEST(IEN,NAM)
  1.  . I IEN F S=1:1 S STR=$P($T(TSPEC+S),";;",2) Q:STR=""  D
  1.  . . S SIEN=$P(STR,";"),SNAM=$$UP^XLFSTR($P(STR,";",2)),SCODE=$P(STR,";",3)
  1.  . . I SIEN'=$$FIND1("TSPEC",SNAM,SCODE) D SPEC(IEN,SIEN,SNAM,SCODE)
  1.  ; *** ReIndex
  1.  K ^LAB(69.73,"B")
  1.  S DIK="^LAB(69.73," D IXALL2^DIK,IXALL^DIK
  1.  Q
  1.  ;
  1. TEST(IEN,NAM) ; Get/Set the old global entry
  1.  Q:'$D(^LAB(69.73,IEN)) 0
  1.  N NEW,CT,STR,CAP
  1.  S NEW=$$FIND1("TTEST",NAM) I NEW D
  1.  . 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
  1.  . . S STR=CT,$P(STR,",",2)=NEW
  1.  . . S CAP(STR)=@CT
  1.  . . I $QL(CT)=3,$QS(CT,3)=0 S CAP(STR)=NEW
  1.  K ^LAB(69.73,IEN)
  1.  Q:'$D(CAP) IEN
  1.  S CT="" F  S CT=$O(CAP(CT)) Q:CT=""  S:$E(CT,1,11)="^LAB(69.73," @CT=CAP(CT)
  1.  Q NEW
  1.  ;
  1. SPEC(IEN,SPC,NAM,CODE) ; Get the old global sub entry for specimen
  1.  N NEW,CT,STR,CAP
  1.  S NEW=$$FIND1("TSPEC",NAM,CODE) I NEW D
  1.  . 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
  1.  . . S STR=CT,$P(STR,",",4)=NEW
  1.  . . S CAP(STR)=@CT
  1.  . . I $QL(CT)=5,$QS(CT,5)=0 S CAP(STR)=NEW
  1.  Q:'$D(CAP)
  1.  K ^LAB(69.73,IEN,3,SPC)
  1.  S CT="" F  S CT=$O(CAP(CT)) Q:CT=""  S:$E(CT,1,11+$L(IEN))="^LAB(69.73,"_IEN @CT=CAP(CT)
  1.  Q
  1.  ;
  1. FIND1(TAG,NAM,CODE) ; Lookup
  1.  N CT,IEN,SUCCS,SPEC
  1.  S NAM=$$UP^XLFSTR($G(NAM)),CODE=$G(CODE),SUCCS=0
  1.  I TAG="TTEST" D
  1.  . Q:'$D(^ORD(101.43,"B",NAM))
  1.  . S (CT,IEN)=0 F  S CT=$O(^ORD(101.43,"B",NAM,CT)) Q:'CT  D
  1.  . . Q:$$UP^XLFSTR($P($G(^ORD(101.43,CT,0)),U))'=NAM
  1.  . . Q:$$UP^XLFSTR($$GET1^DIQ(101.43,CT_",",5))'="ANATOMIC PATHOLOGY"
  1.  . . S SUCCS=SUCCS+1,IEN=CT
  1.  I TAG="TSPEC" D
  1.  . Q:CODE=""
  1.  . K SPEC S (CT,SUCCS)=0 F  S CT=$O(^LAB(61,"F",CODE,CT)) Q:'CT  D
  1.  . . S SPEC(CT)=$$UP^XLFSTR($P($G(^LAB(61,CT,0)),U)),SUCCS=SUCCS+1,IEN=CT
  1.  . I SUCCS>1 D  Q
  1.  . . S (CT,SUCCS,IEN)=0 F  S CT=$O(SPEC(CT)) Q:'CT  D
  1.  . . . I SPEC(CT)=NAM S SUCCS=SUCCS+1,IEN=CT
  1.  . . I SUCCS>1 S IEN=0
  1.  Q $S(SUCCS'=1:0,$G(IEN):IEN,1:0)
  1.  ;
  1. BUILD ; Build the Transport Routine Text
  1.  N ND,SP,SPEC
  1.  I '$D(^LAB(69.73,"B")) W !,"***** No configuration to print. *****",! Q
  1.  W !,"TTEST ; Dialog data to convert",!
  1.  S ND=0 F  S ND=$O(^LAB(69.73,"B",ND)) Q:'ND  D
  1.  . W " ;;",ND,";",$P($G(^ORD(101.43,ND,0)),U),!
  1.  W " ;;",!," Q",!," ;",!
  1.  W "TSPEC ; Specimen data to convert",!
  1.  S ND=$NA(^LAB(69.73)) F  S ND=$Q(@ND) Q:ND=""  Q:$QS(ND,1)'=69.73  D
  1.  . I $QS(ND,3)=3,$QS(ND,5)=0 D
  1.  . . S SP=$P($G(^LAB(61,+$P(@ND,U),0)),U) I SP'="" D
  1.  . . . S SPEC(SP)=+$P(@ND,U)_";"_SP_";"_$$GET1^DIQ(61,+$P(@ND,U)_",",20)
  1.  I $D(SPEC) S SP="" F  S SP=$O(SPEC(SP)) Q:SP=""  W " ;;",SPEC(SP),!
  1.  W " ;;",!," Q",!
  1.  Q
  1.  ;
  1.  ; ******** RUN BUILD ABOVE AND UPDATE BELOW THIS LINE WITH THE OUTPUT ********
  1.  ;
  1. TTEST ; Dialog data to convert
  1.  ;;766;BONE MARROW
  1.  ;;4968;BRONCHIAL BIOPSY
  1.  ;;4969;BRONCHIAL CYTOLOGY
  1.  ;;4970;DERMATOLOGY
  1.  ;;4971;FINE NEEDLE ASPIRATE
  1.  ;;4972;GASTROINTESTINAL ENDOSCOPY
  1.  ;;4974;GENERAL FLUID
  1.  ;;4975;GYNECOLOGY (PAP SMEAR)
  1.  ;;4976;TISSUE EXAM
  1.  ;;4977;UROLOGY,BLADDER/URETER
  1.  ;;4978;UROLOGY,PROSTATE
  1.  ;;4979;RENAL BIOPSY
  1.  ;;4980;URINE
  1.  ;;
  1.  Q
  1.  ;
  1. TSPEC ; Specimen data to convert
  1.  ;;114;ABDOMEN;113345001
  1.  ;;23;ADRENAL GLAND;23451007
  1.  ;;5451;ANAL CANAL;34381000
  1.  ;;66;APPENDIX;66754008
  1.  ;;5401;ASCENDING COLON;9040008
  1.  ;;5137;BILE DUCT CYTOLOGIC MATERIAL;110928002
  1.  ;;5079;BILE DUCT MUCOUS MEMBRANE;7035006
  1.  ;;4707;BILIARY TRACT;34707002
  1.  ;;5117;BODY OF PANCREAS;40133006
  1.  ;;322;BONE;3138006
  1.  ;;319;BONE MARROW;14016003
  1.  ;;318;BREAST;76752008
  1.  ;;3533;BRONCHIAL CYTOLOGIC MATERIAL;110912007
  1.  ;;336;BRONCHUS;955009
  1.  ;;5248;CARDIAC INCISURE OF STOMACH;5459006
  1.  ;;5246;CARDIAC OSTIUM OF STOMACH;63853002
  1.  ;;5205;CARDIO-ESOPHAGEAL JUNCTION;25271004
  1.  ;;231;CECUM;32713005
  1.  ;;6464;CEREBROSPINAL FLUID CYTOLOGIC MATERIAL;110969006
  1.  ;;6242;CERVICAL CYTOLOGIC MATERIAL;110949001
  1.  ;;6079;CHORIONIC VILLI;2049008
  1.  ;;67;COLON;71854001
  1.  ;;5405;DESCENDING COLON;32622004
  1.  ;;64;DUODENUM;38848004
  1.  ;;62;ESOPHAGUS;32849002
  1.  ;;5204;ESOPHAGUS, LOWER THIRD;67173009
  1.  ;;5202;ESOPHAGUS, MIDDLE THIRD;19000002
  1.  ;;5200;ESOPHAGUS, UPPER THIRD;54738009
  1.  ;;5247;GASTRIC FUNDUS;414003
  1.  ;;5482;GASTRIC JUICE;31773000
  1.  ;;5241;GREATER CURVATURE OF STOMACH;89382009
  1.  ;;5114;HEAD OF PANCREAS;64163001
  1.  ;;5336;ILEUM;34516001
  1.  ;;5329;JEJUNUM;21306003
  1.  ;;22;KIDNEY;64033007
  1.  ;;5404;LEFT COLIC FLEXURE;72592005
  1.  ;;17;LEFT TESTIS;63239009
  1.  ;;5239;LESSER CURVATURE OF STOMACH;80085006
  1.  ;;56;LIVER;10200004
  1.  ;;21;LUNG;39607008
  1.  ;;213;LYMPH NODE;59441001
  1.  ;;172;MEDIASTINUM;72410000
  1.  ;;8310;NECK, LEFT SIDE;170583000
  1.  ;;8309;NECK, RIGHT SIDE;170303002
  1.  ;;4;PANCREAS;15776009
  1.  ;;4946;PAROTID GLAND;45289007
  1.  ;;116;PELVIS;12921003
  1.  ;;3758;PERICARDIAL CYTOLOGIC MATERIAL;110919003
  1.  ;;5569;PERIRENAL TISSUE;47145004
  1.  ;;5504;PERITONEAL CYTOLOGIC MATERIAL;110944006
  1.  ;;171;PERITONEUM;15425007
  1.  ;;3561;PLEURAL CYTOLOGIC MATERIAL;110913002
  1.  ;;15;PROSTATE;41216001
  1.  ;;5252;PYLORIC ANTRUM;66051006
  1.  ;;5254;PYLORUS;280119005
  1.  ;;5443;RECTOSIGMOID JUNCTION;49832006
  1.  ;;68;RECTUM;34402009
  1.  ;;186;RENAL PELVIS;25990002
  1.  ;;143;RETROPERITONEUM;82849001
  1.  ;;5402;RIGHT COLIC FLEXURE;48338005
  1.  ;;16;RIGHT TESTIS;15598003
  1.  ;;55;SALIVARY GLAND;385294005
  1.  ;;5406;SIGMOID COLON;60184004
  1.  ;;315;SKIN;39937001
  1.  ;;5273;SMALL INTESTINE;30315005
  1.  ;;314;SOFT TISSUES;87784001
  1.  ;;3;SPLEEN;78961009
  1.  ;;63;STOMACH;69695003
  1.  ;;4960;SUBLINGUAL GLAND;88481005
  1.  ;;4968;SUBMAXILLARY GLAND;54019009
  1.  ;;8433;SUBPHRENIC FOSSA;243974009
  1.  ;;3117;SYNOVIAL CYTOLOGIC MATERIAL;110895009
  1.  ;;5125;TAIL OF PANCREAS;73239005
  1.  ;;5;THYROID GLAND;69748006
  1.  ;;8729;TISSUE;85756007
  1.  ;;5403;TRANSVERSE COLON;485005
  1.  ;;351;URETER;87953007
  1.  ;;87;URINARY BLADDER;89837001
  1.  ;;71;URINE;78014005
  1.  ;;234;VAS DEFERENS;57671007
  1.  ;;189;VERTEBRA;51282000
  1.  ;;
  1.  Q