- HDISDOLL ;BPFO/DTG - DISPLAY LOOKUP ITEMS FOR LABORATORY; Apr 07, 2018@12:42
- ;;1.0;HEALTH DATA & INFORMATICS;**22**;Feb 22, 2005;Build 26
- ;
- ;
- EN ; Display found orderable items for Lab
- ;
- ;
- ;
- ; put XML into tmp file
- ;^TMP("HDISDOLL",$J,"T")= Orderable Item Type (P, L, or R)
- ;^TMP("HDISDOLL",$J,"F",1)=FACILITY NAME-NUMBER^Production Y/N^NET NAME^type of lookup (single, Partial Match, ALL)^Partial Name
- ;^TMP("HDISDOLL",$J,0)= O# of orderable items
- ;^TMP("HDISDOLL",$J,O#,1)=orderable item IEN^orderable item name^mnemonic^status^inactive date
- ;^TMP("HDISDOLL",$J,O#,"S",0)= S# of synonyms
- ;^TMP("HDISDOLL",$J,O#,"S",S#)= synonym
- ;^TMP("HDISDOLL",$J,O#,"LPI",0)= LPI# of primary test items (#60) tests associated to 101.43 item
- ;^TMP("HDISDOLL",$J,O#,"LPI",LPI#,1)=IEN^name^Panel^ if error
- ;^TMP("HDISDOLL",$J,O#,"LPI",LPI#,"LTI",0)= LTI# of lab test items (#60)
- ;^TMP("HDISDOLL",$J,O#,"LPI",LPI#,"LTI",LTI,1)=IEN^name^type^data location^data physical location^status^inactive dt
- ;^TMP("HDISDOLL",$J,O#,"LPI",LPI#,"LTI",LTI,"LTS",0)= LTS# of specimens for LTI (60.01)
- ;^TMP("HDISDOLL",$J,O#,"LPI",LPI#,"LTI",LTI,"LTS",LTS,1)=IEN^name^units^inactive dt^status
- ;^TMP("HDISDOLL",$J,O#,"LPI",LPI#,"LTI",LTI,"LTS",LTS,2)=MLTF IEN^mltf name^mltf alt name^mltf inactive dt
- ;^TMP("HDISDOLL",$J,O#,"LPI",LPI#,"LTI",LTI,"LTS",LTS,3)=mltf status^mltf LOINC Code^mltf componet^mltf property
- ;^TMP("HDISDOLL",$J,O#,"LPI",LPI#,"LTI",LTI,"LTS",LTS,4)=mltf time aspect^mltf specimen^mltf scale^mltf method
- ;
- ;
- EN1 ;
- N LPI,LPIEN,LPNM,LPO1,LPPN,LTI1,LTIDA,LTIDAP,LTIDT,LTIEN,LTINM,TAB,LTI,LTS,HDIORD
- N LTIST,LTITYP,LTMANM,LTMCOM,LTMDT,LTMIEN,LTMLON,LTMMET,LTMNM,LTMPRO,LTMSCA,LTMSPC
- N LTMST,LTMTIM,LTS1,LTS2,LTS3,LTS4,LTSDT,LTSIEN,LTSNM,LTSST,LTSUN,M,HDIV,HD,HD1,HD2
- N O10143,OIDT,OIEN,OIMEN,OINM,OIST,OISYN,OK,OK1,QUIT,R,D,HDIA,HDIFAC,HDIOI,HDIORD,LPPER
- S HDIV="^TMP(""HDISDOLP"",$J)" K @HDIV
- S A=1,TAB=$C(9),QUIT=""
- I HDITYPE="X" G XML
- L1 S A=$O(@RET1@(A)) I 'A G L1E
- S B=$G(@RET1@(A)) I B["</Laboratory_Orderable_Items>" G L1E
- I A=2&(B["<Laboratory_Orderable_Items") S @HDIV@("T")="LABORATORY" G L1
- I B="<Facility>" S M="" G L1
- I B["<Facility_Name-Number>" S $P(M,U,1)=$$N(B) G L1
- I B["<Facility_Production_Account>" S $P(M,U,2)=$$N(B) G L1
- I B["<Facility_Net_Name>" S $P(M,U,3)=$$N(B) G L1
- I B["<Look_up_Type>" S $P(M,U,4)=$$N(B) G L1
- I B["<Look_up_Partial_Name>" S $P(M,U,5)=$$N(B) G L1
- I B["</Facility>" S @HDIV@("F",1)=M G L1
- I B="<Orderable_Item>" D G L1
- . S C=$G(@HDIV@(0)),C=C+1,@HDIV@(0)=C,HDIORD=C,HDIOI="",OK=0,OK1=0
- . F S A=$O(@RET1@(A)),B=$G(@RET1@(A)) Q:B["</Orderable_Item>" D ;<
- . . I B["<Orderable_Item_Number>" S $P(HDIOI,U,1)=$$N(B) Q
- . . I B["<Orderable_Item_Name>" S C=$$N(B),$P(HDIOI,U,2)=$$CHAR(C) Q
- . . I B["<Orderable_Item_Mnemonic>" S C=$$N(B),$P(HDIOI,U,3)=$$CHAR(C) Q
- . . I B["<Orderable_Item_Inactive_Date>" S $P(HDIOI,U,4)=$$N(B) Q
- . . I B["<Orderable_Item_Status>" S $P(HDIOI,U,5)=$$N(B),@HDIV@(HDIORD,1)=HDIOI Q
- . . I B["<Orderable_Item_Synonym>" F S A=$O(@RET1@(A)),B=$G(@RET1@(A)) D I OK1=1 Q
- . . . I B["<Orderable_Item_Synonym_Name>" D Q
- . . . . S D=$G(@HDIV@(HDIORD,"S",0)),D=D+1,@HDIV@(HDIORD,"S",0)=D,C=$$N(B),@HDIV@(HDIORD,"S",D)=$$CHAR(C) Q
- . . . I B["</Orderable_Item_Synonym>" Q
- . . . I B["<Lab_Primary_Order_Item>" S A=A-1,OK1=1 Q
- . . I B="<Lab_Primary_Order_Item>" D Q
- . . . S C=$G(@HDIV@(HDIORD,"LPI",0)),C=C+1,@HDIV@(HDIORD,"LPI",0)=C,LPI=C,(LPO1,OK,OK1)=""
- . . . F S A=$O(@RET1@(A)),B=$G(@RET1@(A)) Q:B["</Lab_Primary_Order_Item>" D ;<
- . . . . I B["<Lab_Primary_Test_IEN>" S LPO1=$$N(B) Q
- . . . . I B["<Lab_Primary_Test_Name>" S R=$$N(B),$P(LPO1,U,2)=$$CHAR(R) Q
- . . . . I B["Lab_Primary_Test_Panel>" S $P(LPO1,U,3)=$$N(B),@HDIV@(HDIORD,"LPI",LPI,1)=LPO1 Q
- . . . . I B="<Laboratory_Test_Item>" S C=$G(@HDIV@(HDIORD,"LPI",LPI,"LTI",0)),C=C+1,@HDIV@(HDIORD,"LPI",LPI,"LTI",0)=C,LTI=C,LTI1="" F S A=$O(@RET1@(A)),B=$G(@RET1@(A)) Q:B["</Laboratory_Test_Item>" D ;<
- . . . . . I B["<Lab_Test_IEN>" S LTI1=$$N(B) Q
- . . . . . I B["<Lab_Test_Name>" S C=$$N(B),$P(LTI1,U,2)=$$CHAR(C) Q
- . . . . . I B["<Lab_Test_Type>" S $P(LTI1,U,3)=$$N(B) Q
- . . . . . I B["<Lab_Test_Data_Location>" S $P(LTI1,U,4)=$$N(B) Q
- . . . . . I B["<Lab_Test_Data_Loc_Physical>" S $P(LTI1,U,5)=$$N(B) Q
- . . . . . I B["<Lab_Test_Inactive_Date>" S $P(LTI1,U,6)=$$N(B) Q
- . . . . . I B["<Lab_Test_Status>" S $P(LTI1,U,7)=$$N(B),@HDIV@(HDIORD,"LPI",LPI,"LTI",LTI,1)=LTI1 Q
- . . . . . I B="<Lab_Test_Specimen>" S C=$G(@HDIV@(HDIORD,"LPI",LPI,"LTI",LTI,"LTS",0)),C=C+1,@HDIV@(HDIORD,"LPI",LPI,"LTI",LTI,"LTS",0)=C,LTS=C,(LTS1,LTS2,LTS3,LTS4)="" F S A=$O(@RET1@(A)),B=$G(@RET1@(A)) Q:B["</Lab_Test_Specimen>" D ;<
- . . . . . . I B["<Lab_Test_Specimen_IEN>" S LTS1=$$N(B) Q
- . . . . . . I B["<Lab_Test_Specimen_Name>" S C=$$N(B),$P(LTS1,U,2)=$$CHAR(C) Q
- . . . . . . I B["<Lab_Test_Specimen_Units>" S C=$$N(B),$P(LTS1,U,3)=$$CHAR(C) Q
- . . . . . . I B["<Lab_Test_Specimen_Inactive_Date>" S $P(LTS1,U,4)=$$N(B)
- . . . . . . I B["<Lab_Test_Specimen_Status>" S $P(LTS1,U,5)=$$N(B),@HDIV@(HDIORD,"LPI",LPI,"LTI",LTI,"LTS",LTS,1)=LTS1 Q
- . . . . . . I B="<Master_Lab_Test_Item>" Q
- . . . . . . I B="</Master_Lab_Test_Item>" Q
- . . . . . . I B["<Master_Lab_Test_IEN>" S LTS2=$$N(B) Q
- . . . . . . I B["<Master_Lab_Test_Name>" S C=$$N(B),$P(LTS2,U,2)=$$CHAR(C) Q
- . . . . . . I B["<Master_Lab_Test_Alternate_Name>" S C=$$N(B),$P(LTS2,U,3)=$$CHAR(C) Q
- . . . . . . I B["<Master_Lab_Test_Inactive_Date>" S $P(LTS2,U,4)=$$N(B),@HDIV@(HDIORD,"LPI",LPI,"LTI",LTI,"LTS",LTS,2)=LTS2 Q
- . . . . . . I B["<Master_Lab_Test_Status>" S LTS3=$$N(B) Q
- . . . . . . I B["<Master_Lab_Test_LOINC_Code>" S $P(LTS3,U,2)=$$N(B) Q
- . . . . . . I B["<Master_Lab_Test_Component>" S C=$$N(B),$P(LTS3,U,3)=$$CHAR(C) Q
- . . . . . . I B["<Master_Lab_Test_Property>" S C=$$N(B),$P(LTS3,U,4)=$$CHAR(C),@HDIV@(HDIORD,"LPI",LPI,"LTI",LTI,"LTS",LTS,3)=LTS3 Q
- . . . . . . I B["<Master_Lab_Test_Time_Aspect>" S LTS4=$$N(B) Q
- . . . . . . I B["<Master_Lab_Test_Specimen>" S C=$$N(B),$P(LTS4,U,2)=$$CHAR(C) Q
- . . . . . . I B["<Master_Lab_Test_Scale>" S C=$$N(B),$P(LTS4,U,3)=$$CHAR(C) Q
- . . . . . . I B["<Master_Lab_Test_Method>" S C=$$N(B),$P(LTS4,U,4)=$$CHAR(C),@HDIV@(HDIORD,"LPI",LPI,"LTI",LTI,"LTS",LTS,4)=LTS4 Q
- ;
- L1E ; end of flip from XML
- ;
- ;
- I HDITYPE="R" G REPORT
- G EXPORT
- Q
- ;
- REPORT ;
- ; basic repeats
- S HDIFAC=$G(@HDIV@("F",1)),HDIA=$G(@HDIV@("T")),QUIT="",PAGE=1
- S HD="HDI Orderable Items SDO List For: "_HDIA
- s HD1=$P(HDIFAC,U,1)_" "_($S($P(HDIFAC,U,2)="NO":"NOT-",1:""))_"PRODUCTION"
- S HD2="Type of Lookup: "_$P(HDIFAC,U,4)
- I $P(HDIFAC,U,4)="PARTIAL" S HD2=HD2_" Partial Name: "_$P(HDIFAC,U,5)
- S XDD=^DD("DD"),ULINE="",$P(ULINE,"_",79)="_"
- U IO
- S O10143=0,QUIT=""
- R1 D GETORD I 'O10143 G PDONE
- D RHEAD,RORD S LPI=0
- R2 D GETLPI I 'LPI D PAUSE G PDONE:QUIT,R1
- D RLPI I QUIT G PDONE
- I LPPER G R1
- S LTI=0
- R3 D GETLTI I 'LTI G R2
- D RLTI I QUIT G PDONE
- S LTS=0
- R4 D GETLTS I 'LTS G R3
- D RLTS1 I QUIT G PDONE
- D RLTS2 I QUIT G PDONE
- G R4
- ;
- RCHKC I HDICRT,($Y>(IOSL-4)) D I QUIT Q
- .D PAUSE
- .Q:QUIT
- .;W @IOF
- .W !
- .I HDITYPE'="X" D RHEAD
- E I ('HDICRT),($Y>(IOSL-2)) D
- .W @IOF
- .I HDITYPE'="X" D RHEAD
- ;
- Q
- ;
- PAUSE N DIR,DIRUT,X,Y
- ;F Q:$Y>(IOSL-3) W !
- I 'HDICRT Q
- ; W !
- S DIR(0)="E" D ^DIR
- I ('(+Y))!$D(DIRUT) S QUIT=1
- I 'QUIT S $Y=0
- Q
- ;
- DONE ; final quit point
- K @HDIV,@RET1,RET1
- K LPI,LPIEN,LPNM,LPO1,LPPN,LTI1,LTIDA,LTIDAP,LTIDT,LTIEN,LTINM,TAB,LTI,LTS,HDIORD
- K LTIST,LTITYP,LTMANM,LTMCOM,LTMDT,LTMIEN,LTMLON,LTMMET,LTMNM,LTMPRO,LTMSCA,LTMSPC
- K LTMST,LTMTIM,LTS1,LTS2,LTS3,LTS4,LTSDT,LTSIEN,LTSNM,LTSST,LTSUN,M,HDIV,HD,HD1,HD2
- K O10143,OIDT,OIEN,OIMEN,OINM,OIST,OISYN,OK,OK1,QUIT,R,D,HDIA,HDIFAC,HDIOI,HDIORD,LPPER
- Q
- ;
- PLE ;
- PDONE ; print done
- I 'HDICRT D ^%ZISC
- U IO W !!,?29,$S(QUIT'=1:"--- Report Finished ---",1:"--- Report Aborted ---")
- G DONE
- Q
- ;
- ;
- RHEAD ;Description: Prints the report header.
- Q:QUIT
- N LINE
- I $Y>1 W @IOF
- W !,?(40-($L(HD)\2)),HD
- W !,?(40-($L(HD1)\2)),HD1
- W !,?(40-($L(HD2)\2)),HD2
- W !,?27,"Date Printed: "_$$FMTE^XLFDT(DT),?70,"Page ",PAGE
- S PAGE=PAGE+1
- ;
- W !,ULINE
- Q
- ;
- RORD ; print order info
- D RCHKC Q:QUIT
- W !,"Orderable Item Name: ",OINM
- D RCHKC Q:QUIT
- W !," IEN: ",OIEN,?15,"Mnemonic: ",$S(($E(OIMEN)="Y"):"Yes",1:"No"),?29,"Inactive Date: ",OIDT
- D RCHKC Q:QUIT
- W ?63,"Status: ",$S(OIST=1:"Inactive",1:" Active")
- D RCHKC Q:QUIT
- W !," Synonyms: "
- S A=12,B=0,C="" F S B=$O(OISYN(B)) Q:'B S C=$G(OISYN(B)) D:(A+($L(C)+1)>78) RCHKC Q:QUIT W:(A+($L(C)+1)>78) !," " W C W:(B'=OISYN(0)) ", " S A=$S((A+($L(C)+2)>78):2,1:A)+($L(C)+2)
- D RCHKC Q:QUIT
- W !,ULINE
- Q
- ;
- RLPI ; print lab primary info
- D RCHKC Q:QUIT
- I LPPER D Q
- . W !,"Laboratory Primary Item for Orderable Item: ",$E(LPNM,1,33),"..."
- . D RCHKC Q:QUIT
- . W !,"With IEN of: ",LTIEN," Not Found in Laboratory Test File"
- W !,"Laboratory Primary Item: ",LPNM,?70,"IEN: ",$E(" ",1,(5-$L(LPIEN))),LPIEN
- D RCHKC Q:QUIT
- W !," Panel: ",LPPN
- Q
- ;
- RLTI ; print lab test
- D RCHKC Q:QUIT
- W !,"Laboratory Test: ",LTINM,?70,"IEN: ",$E(" ",1,(5-$L(LTIEN))),LTIEN
- D RCHKC Q:QUIT
- W !," Type: ",$P(LTITYP," ",1),?17,"Data Location: ",LTIDA,?46,"Data Loc Physical: ",LTIDAP
- D RCHKC Q:QUIT
- W !," Inactive Date: ",LTIDT,?61,"Status: " I LTIEN&(LTINM'="") W $S(($E(LTIST)=1):"Inactive",1:" Active")
- Q
- ;
- RLTS1 ; print specimen info
- D RCHKC Q:QUIT
- W !,"Specimen: ",LTSNM,?70,"IEN: ",$E(" ",1,(5-$L(LTSIEN))),LTSIEN
- D RCHKC I QUIT Q
- W !," Units: ",LTSUN,?22,"Inactive Date: ",LTSDT,?61,"Status: " I LTSIEN&(LTSNM'="") W $S(($E(LTSST)=1):"Inactive",1:" Active")
- Q
- ;
- RLTS2 ; print initial mltf info
- D RCHKC Q:QUIT
- I LTMNM="" D Q
- . W !,"Master Lab Test Name: SPECIMEN NOT ASSOCIATED TO MASTER LABORATORY TEST File"
- W !,"Master Lab Test Name: "
- D DISPL(LTMNM,53,71) I QUIT Q
- ;
- D RCHKC Q:QUIT
- W !," IEN: ",LTMIEN,?18,"Inactive DT: ",LTMDT,?61,"Status: " I LTMIEN&(LTMNM'="") W $S(($E(LTMST)=1):"Inactive",1:" Active")
- ;
- D RCHKC Q:QUIT
- W !," Alternate Name: "
- D DISPL(LTMANM,56,71) I QUIT Q
- ;
- D RCHKC Q:QUIT
- W !," LOINC Code: ",LTMLON
- ;
- D RCHKC Q:QUIT
- W !," Component: "
- D DISPL(LTMCOM,63,71) I QUIT Q
- ;
- D RCHKC Q:QUIT
- W !," Property: "
- D DISPL(LTMPRO,63,71) I QUIT Q
- ;
- D RCHKC Q:QUIT
- W !," Time Aspect: "
- D DISPL(LTMTIM,61,71) I QUIT Q
- ;
- W !," Specimen: "
- D DISPL(LTMSPC,63,71) I QUIT Q
- ;
- D RCHKC Q:QUIT
- W !," Scale: "
- D DISPL(LTMSCA,66,71) I QUIT Q
- ;
- D RCHKC Q:QUIT
- W !," Method: "
- D DISPL(LTMTIM,65,71) I QUIT Q
- Q
- ;
- EXPORT ; output as export file
- ; basic repeats
- S HDIFAC=$G(@HDIV@("F",1)),HDIA=$G(@HDIV@("T"))
- ; walk collection
- S O10143=0 D EHEAD
- E1 D GETORD I 'O10143 G EOUT
- S LPI=0
- E2 D GETLPI I 'LPI G E1
- S LTI=0
- E3 D GETLTI I 'LTI G E2
- S LTS=0
- E4 D GETLTS I 'LTS G E3
- ; output data
- U IO W $P(HDIFAC,U,1),TAB,$P(HDIFAC,U,2),TAB,$P(HDIFAC,U,3),TAB,HDIA,TAB,$P(HDIFAC,U,4),TAB,$P(HDIFAC,U,5),TAB
- W OIEN,TAB,OINM,TAB,($S(($E(OIMEN)="Y"):"Yes",1:"No")),TAB,OIDT,TAB,($S(OIST=1:"Inactive",1:"Active")),TAB
- ; get synonyms
- S A=0 F I=1:1 S A=$O(OISYN(A)) Q:'A S B=$G(OISYN(A)) W B W:(I'=$G(OISYN(0))) ", "
- S A="" I LTIEN&(LTINM'="") S A=$S(LTIST=1:"Inactive",1:"Active")
- W TAB,LPIEN,TAB,LPNM,TAB,LPPN,TAB,LTIEN,TAB,LTINM,TAB,LTITYP,TAB,LTIDA,TAB,LTIDAP,TAB,LTIDT,TAB,A,TAB
- S A="" I LTSIEN&(LTSNM'="") S A=$S(LTSST=1:"Inactive",1:"Active")
- W LTSIEN,TAB,LTSNM,TAB,LTSUN,TAB,LTSDT,TAB,A,TAB,LTMIEN,TAB,LTMNM,TAB,LTMANM,TAB,LTMDT,TAB
- S A="" I LTMIEN&(LTMNM'="") S A=$S(LTMST=1:"Inactive",1:"Active")
- W A,TAB,LTMLON,TAB,LTMCOM,TAB,LTMPRO,TAB,LTMTIM,TAB,LTMSPC,TAB,LTMSCA,TAB,LTMMET
- W !
- G E4
- ;
- EOUT ;
- I 'HDICRT D ^%ZISC
- G DONE
- Q
- ;
- EHEAD ; export header
- U IO W "Facility_Name-Number",TAB,"Production_Account",TAB,"Net_Name",TAB,"Area",TAB,"Type_of_Lookup",TAB
- W "Partial_Name",TAB,"Orderable_Item_IEN",TAB
- W "Orderable_Item_Name",TAB,"Orderable_Item_Mnemonic",TAB,"Orderable_Item_Inactive_Date",TAB,"Orderable_Item_Status",TAB
- W "Orderable_Item_Synonyms",TAB,"Lab_Primary_Test_IEN",TAB,"Lab_Primary_Test_Name",TAB,"Lab_Primary_Test_Panel",TAB
- W "Lab_Test_IEN",TAB,"Lab_Test_Name",TAB,"Lab_Test_Type",TAB,"Lab_Test_Data_Location",TAB,"Lab_Test_Data_Loc_Physical",TAB
- W "Lab_Test_Inactive_Date",TAB,"Lab_Test_Status",TAB,"Lab_Test_Specimen_IEN",TAB,"Lab_Test_Specimen_Name",TAB
- W "Lab_Test_Specimen_Units",TAB,"Lab_Test_Specimen_Inactive_Date",TAB,"Lab_Test_Specimen_Status",TAB
- W "Master_Lab_Test_IEN",TAB,"Master_Lab_Test_Name",TAB,"Master_Lab_Test_Alternate_Name",TAB,"Master_Lab_Test_Inactive_Date",TAB
- W "Master_Lab_Test_Status",TAB,"Master_Lab_Test_LOINC_Code",TAB,"Master_Lab_Test_Component",TAB
- W "Master_Lab_Test_Property",TAB,"Master_Lab_Test_Time_Aspect",TAB,"Master_Lab_Test_Specimen",TAB
- W "Master_Lab_Test_Scale",TAB,"Master_Lab_Test_Method"
- W !
- Q
- ;
- GETORD S (OIEN,OINM,OIMEN,OIDT,OIST)=""
- S O10143=$O(@HDIV@(O10143)) I 'O10143 Q
- S B=$G(@HDIV@(O10143,1)),OIEN=$P(B,U,1),OINM=$P(B,U,2),OIMEN=$P(B,U,3),OIDT=$P(B,U,4),OIST=$P(B,U,5)
- K OISYN M OISYN=@HDIV@(O10143,"S")
- Q
- ;
- GETLPI ; get primary lab item
- S (LPIEN,LPNM,LPPN,LPPER)=""
- N C
- S LPI=$O(@HDIV@(O10143,"LPI",LPI)) I 'LPI Q
- S B=$G(@HDIV@(O10143,"LPI",LPI,1)),LPIEN=$P(B,U,1),LPNM=$P(B,U,2),LPPN=$P(B,U,3)
- I $P(B,U,4)'="" S C=$P(B,U,4),LPIEN=$P(C,":",1),LPNM=$P(C,":",2),LPPER=1
- Q
- ;
- GETLTI ; get lab test item
- S (LTIEN,LTINM,LTITYP,LTIDA,LTIDAP,LTIDT,LTIST)=""
- S LTI=$O(@HDIV@(O10143,"LPI",LPI,"LTI",LTI)) I 'LTI Q
- S B=$G(@HDIV@(O10143,"LPI",LPI,"LTI",LTI,1)),LTIEN=$P(B,U,1),LTINM=$P(B,U,2),LTITYP=$P(B,U,3)
- S LTIDA=$P(B,U,4),LTIDAP=$P(B,U,5),LTIDT=$P(B,U,6),LTIST=$P(B,U,7)
- Q
- ;
- GETLTS ; get lab specimen and mltf item
- S (LTSIEN,LTSNM,LTSUN,LTSDT,LTSST,LTMIEN,LTMNM,LTMANM,LTMST,LTMLON,LTMCOM,LTMPRO,LTMTIM,LTMSPC,LTMSCA,LTMMET)=""
- S LTS=$O(@HDIV@(O10143,"LPI",LPI,"LTI",LTI,"LTS",LTS)) I 'LTS Q
- S B=$G(@HDIV@(O10143,"LPI",LPI,"LTI",LTI,"LTS",LTS,1)),LTSIEN=$P(B,U,1),LTSNM=$P(B,U,2),LTSUN=$P(B,U,3)
- S LTSDT=$P(B,U,4),LTSST=$P(B,U,5)
- S B=$G(@HDIV@(O10143,"LPI",LPI,"LTI",LTI,"LTS",LTS,2)),LTMIEN=$P(B,U,1),LTMNM=$P(B,U,2),LTMANM=$P(B,U,3)
- S LTMDT=$P(B,U,4)
- S B=$G(@HDIV@(O10143,"LPI",LPI,"LTI",LTI,"LTS",LTS,3)),LTMST=$P(B,U,1),LTMLON=$P(B,U,2),LTMCOM=$P(B,U,3),LTMPRO=$P(B,U,4)
- S B=$G(@HDIV@(O10143,"LPI",LPI,"LTI",LTI,"LTS",LTS,4)),LTMTIM=$P(B,U,1),LTMSPC=$P(B,U,2),LTMSCA=$P(B,U,3),LTMMET=$P(B,U,4)
- Q
- ;
- CHAR(A) ; check for ctrl chars, <, >, &
- N B,C,D,I,L,M,N
- I A="" Q A
- S D=A
- I A["'AND'" D ;<
- . S B=$F(A,"'AND'")
- . S A=$E(A,1,(B-6))_"&"_$E(A,B,$L(A))
- I A["'LESS THAN'" D ;<
- . S B=$F(A,"'LESS THAN'")
- . S A=$E(A,1,(B-12))_"<"_$E(A,B,$L(A))
- I A["'GREATER THAN'" D ;<
- . S B=$F(A,"'GREATER THAN'")
- . S A=$E(A,1,(B-15))_">"_$E(A,B,$L(A))
- I A["'FORWARD SLASH'" D ;<
- . S B=$F(A,"'FORWARD SLASH'")
- . S A=$E(A,1,(B-16))_"/"_$E(A,B,$L(A))
- Q A
- ;
- N(K) ;get value
- N F
- S F=$P($P(K,"<",2),">",2)
- Q F
- ;
- XML ; entry if output is XML
- U IO
- N A,B,C S A=0
- F S A=$O(@RET1@(A)) Q:'A W $G(@RET1@(A)),! ; D RCHKC I QUIT Q
- K A,B,C
- ;G PDONE
- I 'HDICRT D ^%ZISC
- Q
- ;
- DISPL(S,F,E) ; display lines
- N A,D
- I S="" Q
- I $L(S)<F W S G DISPL1
- S D=F F Q:S="" S A="" D I QUIT Q ;<
- . S A=$E(S,1,D),S=$E(S,(D+1),$L(S)),D=E
- . W A I S'="" W " <"
- . D RCHKC
- . Q:QUIT
- . I S'="" W !," > "
- DISPL1 ;
- I QUIT Q
- D RCHKC Q:QUIT
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHDISDOLL 15602 printed Feb 18, 2025@23:22:53 Page 2
- HDISDOLL ;BPFO/DTG - DISPLAY LOOKUP ITEMS FOR LABORATORY; Apr 07, 2018@12:42
- +1 ;;1.0;HEALTH DATA & INFORMATICS;**22**;Feb 22, 2005;Build 26
- +2 ;
- +3 ;
- EN ; Display found orderable items for Lab
- +1 ;
- +2 ;
- +3 ;
- +4 ; put XML into tmp file
- +5 ;^TMP("HDISDOLL",$J,"T")= Orderable Item Type (P, L, or R)
- +6 ;^TMP("HDISDOLL",$J,"F",1)=FACILITY NAME-NUMBER^Production Y/N^NET NAME^type of lookup (single, Partial Match, ALL)^Partial Name
- +7 ;^TMP("HDISDOLL",$J,0)= O# of orderable items
- +8 ;^TMP("HDISDOLL",$J,O#,1)=orderable item IEN^orderable item name^mnemonic^status^inactive date
- +9 ;^TMP("HDISDOLL",$J,O#,"S",0)= S# of synonyms
- +10 ;^TMP("HDISDOLL",$J,O#,"S",S#)= synonym
- +11 ;^TMP("HDISDOLL",$J,O#,"LPI",0)= LPI# of primary test items (#60) tests associated to 101.43 item
- +12 ;^TMP("HDISDOLL",$J,O#,"LPI",LPI#,1)=IEN^name^Panel^ if error
- +13 ;^TMP("HDISDOLL",$J,O#,"LPI",LPI#,"LTI",0)= LTI# of lab test items (#60)
- +14 ;^TMP("HDISDOLL",$J,O#,"LPI",LPI#,"LTI",LTI,1)=IEN^name^type^data location^data physical location^status^inactive dt
- +15 ;^TMP("HDISDOLL",$J,O#,"LPI",LPI#,"LTI",LTI,"LTS",0)= LTS# of specimens for LTI (60.01)
- +16 ;^TMP("HDISDOLL",$J,O#,"LPI",LPI#,"LTI",LTI,"LTS",LTS,1)=IEN^name^units^inactive dt^status
- +17 ;^TMP("HDISDOLL",$J,O#,"LPI",LPI#,"LTI",LTI,"LTS",LTS,2)=MLTF IEN^mltf name^mltf alt name^mltf inactive dt
- +18 ;^TMP("HDISDOLL",$J,O#,"LPI",LPI#,"LTI",LTI,"LTS",LTS,3)=mltf status^mltf LOINC Code^mltf componet^mltf property
- +19 ;^TMP("HDISDOLL",$J,O#,"LPI",LPI#,"LTI",LTI,"LTS",LTS,4)=mltf time aspect^mltf specimen^mltf scale^mltf method
- +20 ;
- +21 ;
- EN1 ;
- +1 NEW LPI,LPIEN,LPNM,LPO1,LPPN,LTI1,LTIDA,LTIDAP,LTIDT,LTIEN,LTINM,TAB,LTI,LTS,HDIORD
- +2 NEW LTIST,LTITYP,LTMANM,LTMCOM,LTMDT,LTMIEN,LTMLON,LTMMET,LTMNM,LTMPRO,LTMSCA,LTMSPC
- +3 NEW LTMST,LTMTIM,LTS1,LTS2,LTS3,LTS4,LTSDT,LTSIEN,LTSNM,LTSST,LTSUN,M,HDIV,HD,HD1,HD2
- +4 NEW O10143,OIDT,OIEN,OIMEN,OINM,OIST,OISYN,OK,OK1,QUIT,R,D,HDIA,HDIFAC,HDIOI,HDIORD,LPPER
- +5 SET HDIV="^TMP(""HDISDOLP"",$J)"
- KILL @HDIV
- +6 SET A=1
- SET TAB=$CHAR(9)
- SET QUIT=""
- +7 IF HDITYPE="X"
- GOTO XML
- L1 SET A=$ORDER(@RET1@(A))
- IF 'A
- GOTO L1E
- +1 SET B=$GET(@RET1@(A))
- IF B["</Laboratory_Orderable_Items>"
- GOTO L1E
- +2 IF A=2&(B["<Laboratory_Orderable_Items")
- SET @HDIV@("T")="LABORATORY"
- GOTO L1
- +3 IF B="<Facility>"
- SET M=""
- GOTO L1
- +4 IF B["<Facility_Name-Number>"
- SET $PIECE(M,U,1)=$$N(B)
- GOTO L1
- +5 IF B["<Facility_Production_Account>"
- SET $PIECE(M,U,2)=$$N(B)
- GOTO L1
- +6 IF B["<Facility_Net_Name>"
- SET $PIECE(M,U,3)=$$N(B)
- GOTO L1
- +7 IF B["<Look_up_Type>"
- SET $PIECE(M,U,4)=$$N(B)
- GOTO L1
- +8 IF B["<Look_up_Partial_Name>"
- SET $PIECE(M,U,5)=$$N(B)
- GOTO L1
- +9 IF B["</Facility>"
- SET @HDIV@("F",1)=M
- GOTO L1
- +10 IF B="<Orderable_Item>"
- Begin DoDot:1
- +11 SET C=$GET(@HDIV@(0))
- SET C=C+1
- SET @HDIV@(0)=C
- SET HDIORD=C
- SET HDIOI=""
- SET OK=0
- SET OK1=0
- +12 ;<
- FOR
- SET A=$ORDER(@RET1@(A))
- SET B=$GET(@RET1@(A))
- if B["</Orderable_Item>"
- QUIT
- Begin DoDot:2
- +13 IF B["<Orderable_Item_Number>"
- SET $PIECE(HDIOI,U,1)=$$N(B)
- QUIT
- +14 IF B["<Orderable_Item_Name>"
- SET C=$$N(B)
- SET $PIECE(HDIOI,U,2)=$$CHAR(C)
- QUIT
- +15 IF B["<Orderable_Item_Mnemonic>"
- SET C=$$N(B)
- SET $PIECE(HDIOI,U,3)=$$CHAR(C)
- QUIT
- +16 IF B["<Orderable_Item_Inactive_Date>"
- SET $PIECE(HDIOI,U,4)=$$N(B)
- QUIT
- +17 IF B["<Orderable_Item_Status>"
- SET $PIECE(HDIOI,U,5)=$$N(B)
- SET @HDIV@(HDIORD,1)=HDIOI
- QUIT
- +18 IF B["<Orderable_Item_Synonym>"
- FOR
- SET A=$ORDER(@RET1@(A))
- SET B=$GET(@RET1@(A))
- Begin DoDot:3
- +19 IF B["<Orderable_Item_Synonym_Name>"
- Begin DoDot:4
- +20 SET D=$GET(@HDIV@(HDIORD,"S",0))
- SET D=D+1
- SET @HDIV@(HDIORD,"S",0)=D
- SET C=$$N(B)
- SET @HDIV@(HDIORD,"S",D)=$$CHAR(C)
- QUIT
- End DoDot:4
- QUIT
- +21 IF B["</Orderable_Item_Synonym>"
- QUIT
- +22 IF B["<Lab_Primary_Order_Item>"
- SET A=A-1
- SET OK1=1
- QUIT
- End DoDot:3
- IF OK1=1
- QUIT
- +23 IF B="<Lab_Primary_Order_Item>"
- Begin DoDot:3
- +24 SET C=$GET(@HDIV@(HDIORD,"LPI",0))
- SET C=C+1
- SET @HDIV@(HDIORD,"LPI",0)=C
- SET LPI=C
- SET (LPO1,OK,OK1)=""
- +25 ;<
- FOR
- SET A=$ORDER(@RET1@(A))
- SET B=$GET(@RET1@(A))
- if B["</Lab_Primary_Order_Item>"
- QUIT
- Begin DoDot:4
- +26 IF B["<Lab_Primary_Test_IEN>"
- SET LPO1=$$N(B)
- QUIT
- +27 IF B["<Lab_Primary_Test_Name>"
- SET R=$$N(B)
- SET $PIECE(LPO1,U,2)=$$CHAR(R)
- QUIT
- +28 IF B["Lab_Primary_Test_Panel>"
- SET $PIECE(LPO1,U,3)=$$N(B)
- SET @HDIV@(HDIORD,"LPI",LPI,1)=LPO1
- QUIT
- +29 ;<
- IF B="<Laboratory_Test_Item>"
- SET C=$GET(@HDIV@(HDIORD,"LPI",LPI,"LTI",0))
- SET C=C+1
- SET @HDIV@(HDIORD,"LPI",LPI,"LTI",0)=C
- SET LTI=C
- SET LTI1=""
- FOR
- SET A=$ORDER(@RET1@(A))
- SET B=$GET(@RET1@(A))
- if B["</Laboratory_Test_Item>"
- QUIT
- Begin DoDot:5
- +30 IF B["<Lab_Test_IEN>"
- SET LTI1=$$N(B)
- QUIT
- +31 IF B["<Lab_Test_Name>"
- SET C=$$N(B)
- SET $PIECE(LTI1,U,2)=$$CHAR(C)
- QUIT
- +32 IF B["<Lab_Test_Type>"
- SET $PIECE(LTI1,U,3)=$$N(B)
- QUIT
- +33 IF B["<Lab_Test_Data_Location>"
- SET $PIECE(LTI1,U,4)=$$N(B)
- QUIT
- +34 IF B["<Lab_Test_Data_Loc_Physical>"
- SET $PIECE(LTI1,U,5)=$$N(B)
- QUIT
- +35 IF B["<Lab_Test_Inactive_Date>"
- SET $PIECE(LTI1,U,6)=$$N(B)
- QUIT
- +36 IF B["<Lab_Test_Status>"
- SET $PIECE(LTI1,U,7)=$$N(B)
- SET @HDIV@(HDIORD,"LPI",LPI,"LTI",LTI,1)=LTI1
- QUIT
- +37 ;<
- IF B="<Lab_Test_Specimen>"
- SET C=$GET(@HDIV@(HDIORD,"LPI",LPI,"LTI",LTI,"LTS",0))
- SET C=C+1
- SET @HDIV@(HDIORD,"LPI",LPI,"LTI",LTI,"LTS",0)=C
- SET LTS=C
- SET (LTS1,LTS2,LTS3,LTS4)=""
- FOR
- SET A=$ORDER(@RET1@(A))
- SET B=$GET(@RET1@(A))
- if B["</Lab_Test_Specimen>"
- QUIT
- Begin DoDot:6
- +38 IF B["<Lab_Test_Specimen_IEN>"
- SET LTS1=$$N(B)
- QUIT
- +39 IF B["<Lab_Test_Specimen_Name>"
- SET C=$$N(B)
- SET $PIECE(LTS1,U,2)=$$CHAR(C)
- QUIT
- +40 IF B["<Lab_Test_Specimen_Units>"
- SET C=$$N(B)
- SET $PIECE(LTS1,U,3)=$$CHAR(C)
- QUIT
- +41 IF B["<Lab_Test_Specimen_Inactive_Date>"
- SET $PIECE(LTS1,U,4)=$$N(B)
- +42 IF B["<Lab_Test_Specimen_Status>"
- SET $PIECE(LTS1,U,5)=$$N(B)
- SET @HDIV@(HDIORD,"LPI",LPI,"LTI",LTI,"LTS",LTS,1)=LTS1
- QUIT
- +43 IF B="<Master_Lab_Test_Item>"
- QUIT
- +44 IF B="</Master_Lab_Test_Item>"
- QUIT
- +45 IF B["<Master_Lab_Test_IEN>"
- SET LTS2=$$N(B)
- QUIT
- +46 IF B["<Master_Lab_Test_Name>"
- SET C=$$N(B)
- SET $PIECE(LTS2,U,2)=$$CHAR(C)
- QUIT
- +47 IF B["<Master_Lab_Test_Alternate_Name>"
- SET C=$$N(B)
- SET $PIECE(LTS2,U,3)=$$CHAR(C)
- QUIT
- +48 IF B["<Master_Lab_Test_Inactive_Date>"
- SET $PIECE(LTS2,U,4)=$$N(B)
- SET @HDIV@(HDIORD,"LPI",LPI,"LTI",LTI,"LTS",LTS,2)=LTS2
- QUIT
- +49 IF B["<Master_Lab_Test_Status>"
- SET LTS3=$$N(B)
- QUIT
- +50 IF B["<Master_Lab_Test_LOINC_Code>"
- SET $PIECE(LTS3,U,2)=$$N(B)
- QUIT
- +51 IF B["<Master_Lab_Test_Component>"
- SET C=$$N(B)
- SET $PIECE(LTS3,U,3)=$$CHAR(C)
- QUIT
- +52 IF B["<Master_Lab_Test_Property>"
- SET C=$$N(B)
- SET $PIECE(LTS3,U,4)=$$CHAR(C)
- SET @HDIV@(HDIORD,"LPI",LPI,"LTI",LTI,"LTS",LTS,3)=LTS3
- QUIT
- +53 IF B["<Master_Lab_Test_Time_Aspect>"
- SET LTS4=$$N(B)
- QUIT
- +54 IF B["<Master_Lab_Test_Specimen>"
- SET C=$$N(B)
- SET $PIECE(LTS4,U,2)=$$CHAR(C)
- QUIT
- +55 IF B["<Master_Lab_Test_Scale>"
- SET C=$$N(B)
- SET $PIECE(LTS4,U,3)=$$CHAR(C)
- QUIT
- +56 IF B["<Master_Lab_Test_Method>"
- SET C=$$N(B)
- SET $PIECE(LTS4,U,4)=$$CHAR(C)
- SET @HDIV@(HDIORD,"LPI",LPI,"LTI",LTI,"LTS",LTS,4)=LTS4
- QUIT
- End DoDot:6
- End DoDot:5
- End DoDot:4
- End DoDot:3
- QUIT
- End DoDot:2
- End DoDot:1
- GOTO L1
- +57 ;
- L1E ; end of flip from XML
- +1 ;
- +2 ;
- +3 IF HDITYPE="R"
- GOTO REPORT
- +4 GOTO EXPORT
- +5 QUIT
- +6 ;
- REPORT ;
- +1 ; basic repeats
- +2 SET HDIFAC=$GET(@HDIV@("F",1))
- SET HDIA=$GET(@HDIV@("T"))
- SET QUIT=""
- SET PAGE=1
- +3 SET HD="HDI Orderable Items SDO List For: "_HDIA
- +4 SET HD1=$PIECE(HDIFAC,U,1)_" "_($SELECT($PIECE(HDIFAC,U,2)="NO":"NOT-",1:""))_"PRODUCTION"
- +5 SET HD2="Type of Lookup: "_$PIECE(HDIFAC,U,4)
- +6 IF $PIECE(HDIFAC,U,4)="PARTIAL"
- SET HD2=HD2_" Partial Name: "_$PIECE(HDIFAC,U,5)
- +7 SET XDD=^DD("DD")
- SET ULINE=""
- SET $PIECE(ULINE,"_",79)="_"
- +8 USE IO
- +9 SET O10143=0
- SET QUIT=""
- R1 DO GETORD
- IF 'O10143
- GOTO PDONE
- +1 DO RHEAD
- DO RORD
- SET LPI=0
- R2 DO GETLPI
- IF 'LPI
- DO PAUSE
- if QUIT
- GOTO PDONE
- GOTO R1
- +1 DO RLPI
- IF QUIT
- GOTO PDONE
- +2 IF LPPER
- GOTO R1
- +3 SET LTI=0
- R3 DO GETLTI
- IF 'LTI
- GOTO R2
- +1 DO RLTI
- IF QUIT
- GOTO PDONE
- +2 SET LTS=0
- R4 DO GETLTS
- IF 'LTS
- GOTO R3
- +1 DO RLTS1
- IF QUIT
- GOTO PDONE
- +2 DO RLTS2
- IF QUIT
- GOTO PDONE
- +3 GOTO R4
- +4 ;
- RCHKC IF HDICRT
- IF ($Y>(IOSL-4))
- Begin DoDot:1
- +1 DO PAUSE
- +2 if QUIT
- QUIT
- +3 ;W @IOF
- +4 WRITE !
- +5 IF HDITYPE'="X"
- DO RHEAD
- End DoDot:1
- IF QUIT
- QUIT
- +6 IF '$TEST
- IF ('HDICRT)
- IF ($Y>(IOSL-2))
- Begin DoDot:1
- +7 WRITE @IOF
- +8 IF HDITYPE'="X"
- DO RHEAD
- End DoDot:1
- +9 ;
- +10 QUIT
- +11 ;
- PAUSE NEW DIR,DIRUT,X,Y
- +1 ;F Q:$Y>(IOSL-3) W !
- +2 IF 'HDICRT
- QUIT
- +3 ; W !
- +4 SET DIR(0)="E"
- DO ^DIR
- +5 IF ('(+Y))!$DATA(DIRUT)
- SET QUIT=1
- +6 IF 'QUIT
- SET $Y=0
- +7 QUIT
- +8 ;
- DONE ; final quit point
- +1 KILL @HDIV,@RET1,RET1
- +2 KILL LPI,LPIEN,LPNM,LPO1,LPPN,LTI1,LTIDA,LTIDAP,LTIDT,LTIEN,LTINM,TAB,LTI,LTS,HDIORD
- +3 KILL LTIST,LTITYP,LTMANM,LTMCOM,LTMDT,LTMIEN,LTMLON,LTMMET,LTMNM,LTMPRO,LTMSCA,LTMSPC
- +4 KILL LTMST,LTMTIM,LTS1,LTS2,LTS3,LTS4,LTSDT,LTSIEN,LTSNM,LTSST,LTSUN,M,HDIV,HD,HD1,HD2
- +5 KILL O10143,OIDT,OIEN,OIMEN,OINM,OIST,OISYN,OK,OK1,QUIT,R,D,HDIA,HDIFAC,HDIOI,HDIORD,LPPER
- +6 QUIT
- +7 ;
- PLE ;
- PDONE ; print done
- +1 IF 'HDICRT
- DO ^%ZISC
- +2 USE IO
- WRITE !!,?29,$SELECT(QUIT'=1:"--- Report Finished ---",1:"--- Report Aborted ---")
- +3 GOTO DONE
- +4 QUIT
- +5 ;
- +6 ;
- RHEAD ;Description: Prints the report header.
- +1 if QUIT
- QUIT
- +2 NEW LINE
- +3 IF $Y>1
- WRITE @IOF
- +4 WRITE !,?(40-($LENGTH(HD)\2)),HD
- +5 WRITE !,?(40-($LENGTH(HD1)\2)),HD1
- +6 WRITE !,?(40-($LENGTH(HD2)\2)),HD2
- +7 WRITE !,?27,"Date Printed: "_$$FMTE^XLFDT(DT),?70,"Page ",PAGE
- +8 SET PAGE=PAGE+1
- +9 ;
- +10 WRITE !,ULINE
- +11 QUIT
- +12 ;
- RORD ; print order info
- +1 DO RCHKC
- if QUIT
- QUIT
- +2 WRITE !,"Orderable Item Name: ",OINM
- +3 DO RCHKC
- if QUIT
- QUIT
- +4 WRITE !," IEN: ",OIEN,?15,"Mnemonic: ",$SELECT(($EXTRACT(OIMEN)="Y"):"Yes",1:"No"),?29,"Inactive Date: ",OIDT
- +5 DO RCHKC
- if QUIT
- QUIT
- +6 WRITE ?63,"Status: ",$SELECT(OIST=1:"Inactive",1:" Active")
- +7 DO RCHKC
- if QUIT
- QUIT
- +8 WRITE !," Synonyms: "
- +9 SET A=12
- SET B=0
- SET C=""
- FOR
- SET B=$ORDER(OISYN(B))
- if 'B
- QUIT
- SET C=$GET(OISYN(B))
- if (A+($LENGTH(C)+1)>78)
- DO RCHKC
- if QUIT
- QUIT
- if (A+($LENGTH(C)+1)>78)
- WRITE !," "
- WRITE C
- if (B'=OISYN(0))
- WRITE ", "
- SET A=$SELECT((A+($LENGTH(C)+2)>78):2,1:A)+($LENGTH(C)+2)
- +10 DO RCHKC
- if QUIT
- QUIT
- +11 WRITE !,ULINE
- +12 QUIT
- +13 ;
- RLPI ; print lab primary info
- +1 DO RCHKC
- if QUIT
- QUIT
- +2 IF LPPER
- Begin DoDot:1
- +3 WRITE !,"Laboratory Primary Item for Orderable Item: ",$EXTRACT(LPNM,1,33),"..."
- +4 DO RCHKC
- if QUIT
- QUIT
- +5 WRITE !,"With IEN of: ",LTIEN," Not Found in Laboratory Test File"
- End DoDot:1
- QUIT
- +6 WRITE !,"Laboratory Primary Item: ",LPNM,?70,"IEN: ",$EXTRACT(" ",1,(5-$LENGTH(LPIEN))),LPIEN
- +7 DO RCHKC
- if QUIT
- QUIT
- +8 WRITE !," Panel: ",LPPN
- +9 QUIT
- +10 ;
- RLTI ; print lab test
- +1 DO RCHKC
- if QUIT
- QUIT
- +2 WRITE !,"Laboratory Test: ",LTINM,?70,"IEN: ",$EXTRACT(" ",1,(5-$LENGTH(LTIEN))),LTIEN
- +3 DO RCHKC
- if QUIT
- QUIT
- +4 WRITE !," Type: ",$PIECE(LTITYP," ",1),?17,"Data Location: ",LTIDA,?46,"Data Loc Physical: ",LTIDAP
- +5 DO RCHKC
- if QUIT
- QUIT
- +6 WRITE !," Inactive Date: ",LTIDT,?61,"Status: "
- IF LTIEN&(LTINM'="")
- WRITE $SELECT(($EXTRACT(LTIST)=1):"Inactive",1:" Active")
- +7 QUIT
- +8 ;
- RLTS1 ; print specimen info
- +1 DO RCHKC
- if QUIT
- QUIT
- +2 WRITE !,"Specimen: ",LTSNM,?70,"IEN: ",$EXTRACT(" ",1,(5-$LENGTH(LTSIEN))),LTSIEN
- +3 DO RCHKC
- IF QUIT
- QUIT
- +4 WRITE !," Units: ",LTSUN,?22,"Inactive Date: ",LTSDT,?61,"Status: "
- IF LTSIEN&(LTSNM'="")
- WRITE $SELECT(($EXTRACT(LTSST)=1):"Inactive",1:" Active")
- +5 QUIT
- +6 ;
- RLTS2 ; print initial mltf info
- +1 DO RCHKC
- if QUIT
- QUIT
- +2 IF LTMNM=""
- Begin DoDot:1
- +3 WRITE !,"Master Lab Test Name: SPECIMEN NOT ASSOCIATED TO MASTER LABORATORY TEST File"
- End DoDot:1
- QUIT
- +4 WRITE !,"Master Lab Test Name: "
- +5 DO DISPL(LTMNM,53,71)
- IF QUIT
- QUIT
- +6 ;
- +7 DO RCHKC
- if QUIT
- QUIT
- +8 WRITE !," IEN: ",LTMIEN,?18,"Inactive DT: ",LTMDT,?61,"Status: "
- IF LTMIEN&(LTMNM'="")
- WRITE $SELECT(($EXTRACT(LTMST)=1):"Inactive",1:" Active")
- +9 ;
- +10 DO RCHKC
- if QUIT
- QUIT
- +11 WRITE !," Alternate Name: "
- +12 DO DISPL(LTMANM,56,71)
- IF QUIT
- QUIT
- +13 ;
- +14 DO RCHKC
- if QUIT
- QUIT
- +15 WRITE !," LOINC Code: ",LTMLON
- +16 ;
- +17 DO RCHKC
- if QUIT
- QUIT
- +18 WRITE !," Component: "
- +19 DO DISPL(LTMCOM,63,71)
- IF QUIT
- QUIT
- +20 ;
- +21 DO RCHKC
- if QUIT
- QUIT
- +22 WRITE !," Property: "
- +23 DO DISPL(LTMPRO,63,71)
- IF QUIT
- QUIT
- +24 ;
- +25 DO RCHKC
- if QUIT
- QUIT
- +26 WRITE !," Time Aspect: "
- +27 DO DISPL(LTMTIM,61,71)
- IF QUIT
- QUIT
- +28 ;
- +29 WRITE !," Specimen: "
- +30 DO DISPL(LTMSPC,63,71)
- IF QUIT
- QUIT
- +31 ;
- +32 DO RCHKC
- if QUIT
- QUIT
- +33 WRITE !," Scale: "
- +34 DO DISPL(LTMSCA,66,71)
- IF QUIT
- QUIT
- +35 ;
- +36 DO RCHKC
- if QUIT
- QUIT
- +37 WRITE !," Method: "
- +38 DO DISPL(LTMTIM,65,71)
- IF QUIT
- QUIT
- +39 QUIT
- +40 ;
- EXPORT ; output as export file
- +1 ; basic repeats
- +2 SET HDIFAC=$GET(@HDIV@("F",1))
- SET HDIA=$GET(@HDIV@("T"))
- +3 ; walk collection
- +4 SET O10143=0
- DO EHEAD
- E1 DO GETORD
- IF 'O10143
- GOTO EOUT
- +1 SET LPI=0
- E2 DO GETLPI
- IF 'LPI
- GOTO E1
- +1 SET LTI=0
- E3 DO GETLTI
- IF 'LTI
- GOTO E2
- +1 SET LTS=0
- E4 DO GETLTS
- IF 'LTS
- GOTO E3
- +1 ; output data
- +2 USE IO
- WRITE $PIECE(HDIFAC,U,1),TAB,$PIECE(HDIFAC,U,2),TAB,$PIECE(HDIFAC,U,3),TAB,HDIA,TAB,$PIECE(HDIFAC,U,4),TAB,$PIECE(HDIFAC,U,5),TAB
- +3 WRITE OIEN,TAB,OINM,TAB,($SELECT(($EXTRACT(OIMEN)="Y"):"Yes",1:"No")),TAB,OIDT,TAB,($SELECT(OIST=1:"Inactive",1:"Active")),TAB
- +4 ; get synonyms
- +5 SET A=0
- FOR I=1:1
- SET A=$ORDER(OISYN(A))
- if 'A
- QUIT
- SET B=$GET(OISYN(A))
- WRITE B
- if (I'=$GET(OISYN(0)))
- WRITE ", "
- +6 SET A=""
- IF LTIEN&(LTINM'="")
- SET A=$SELECT(LTIST=1:"Inactive",1:"Active")
- +7 WRITE TAB,LPIEN,TAB,LPNM,TAB,LPPN,TAB,LTIEN,TAB,LTINM,TAB,LTITYP,TAB,LTIDA,TAB,LTIDAP,TAB,LTIDT,TAB,A,TAB
- +8 SET A=""
- IF LTSIEN&(LTSNM'="")
- SET A=$SELECT(LTSST=1:"Inactive",1:"Active")
- +9 WRITE LTSIEN,TAB,LTSNM,TAB,LTSUN,TAB,LTSDT,TAB,A,TAB,LTMIEN,TAB,LTMNM,TAB,LTMANM,TAB,LTMDT,TAB
- +10 SET A=""
- IF LTMIEN&(LTMNM'="")
- SET A=$SELECT(LTMST=1:"Inactive",1:"Active")
- +11 WRITE A,TAB,LTMLON,TAB,LTMCOM,TAB,LTMPRO,TAB,LTMTIM,TAB,LTMSPC,TAB,LTMSCA,TAB,LTMMET
- +12 WRITE !
- +13 GOTO E4
- +14 ;
- EOUT ;
- +1 IF 'HDICRT
- DO ^%ZISC
- +2 GOTO DONE
- +3 QUIT
- +4 ;
- EHEAD ; export header
- +1 USE IO
- WRITE "Facility_Name-Number",TAB,"Production_Account",TAB,"Net_Name",TAB,"Area",TAB,"Type_of_Lookup",TAB
- +2 WRITE "Partial_Name",TAB,"Orderable_Item_IEN",TAB
- +3 WRITE "Orderable_Item_Name",TAB,"Orderable_Item_Mnemonic",TAB,"Orderable_Item_Inactive_Date",TAB,"Orderable_Item_Status",TAB
- +4 WRITE "Orderable_Item_Synonyms",TAB,"Lab_Primary_Test_IEN",TAB,"Lab_Primary_Test_Name",TAB,"Lab_Primary_Test_Panel",TAB
- +5 WRITE "Lab_Test_IEN",TAB,"Lab_Test_Name",TAB,"Lab_Test_Type",TAB,"Lab_Test_Data_Location",TAB,"Lab_Test_Data_Loc_Physical",TAB
- +6 WRITE "Lab_Test_Inactive_Date",TAB,"Lab_Test_Status",TAB,"Lab_Test_Specimen_IEN",TAB,"Lab_Test_Specimen_Name",TAB
- +7 WRITE "Lab_Test_Specimen_Units",TAB,"Lab_Test_Specimen_Inactive_Date",TAB,"Lab_Test_Specimen_Status",TAB
- +8 WRITE "Master_Lab_Test_IEN",TAB,"Master_Lab_Test_Name",TAB,"Master_Lab_Test_Alternate_Name",TAB,"Master_Lab_Test_Inactive_Date",TAB
- +9 WRITE "Master_Lab_Test_Status",TAB,"Master_Lab_Test_LOINC_Code",TAB,"Master_Lab_Test_Component",TAB
- +10 WRITE "Master_Lab_Test_Property",TAB,"Master_Lab_Test_Time_Aspect",TAB,"Master_Lab_Test_Specimen",TAB
- +11 WRITE "Master_Lab_Test_Scale",TAB,"Master_Lab_Test_Method"
- +12 WRITE !
- +13 QUIT
- +14 ;
- GETORD SET (OIEN,OINM,OIMEN,OIDT,OIST)=""
- +1 SET O10143=$ORDER(@HDIV@(O10143))
- IF 'O10143
- QUIT
- +2 SET B=$GET(@HDIV@(O10143,1))
- SET OIEN=$PIECE(B,U,1)
- SET OINM=$PIECE(B,U,2)
- SET OIMEN=$PIECE(B,U,3)
- SET OIDT=$PIECE(B,U,4)
- SET OIST=$PIECE(B,U,5)
- +3 KILL OISYN
- MERGE OISYN=@HDIV@(O10143,"S")
- +4 QUIT
- +5 ;
- GETLPI ; get primary lab item
- +1 SET (LPIEN,LPNM,LPPN,LPPER)=""
- +2 NEW C
- +3 SET LPI=$ORDER(@HDIV@(O10143,"LPI",LPI))
- IF 'LPI
- QUIT
- +4 SET B=$GET(@HDIV@(O10143,"LPI",LPI,1))
- SET LPIEN=$PIECE(B,U,1)
- SET LPNM=$PIECE(B,U,2)
- SET LPPN=$PIECE(B,U,3)
- +5 IF $PIECE(B,U,4)'=""
- SET C=$PIECE(B,U,4)
- SET LPIEN=$PIECE(C,":",1)
- SET LPNM=$PIECE(C,":",2)
- SET LPPER=1
- +6 QUIT
- +7 ;
- GETLTI ; get lab test item
- +1 SET (LTIEN,LTINM,LTITYP,LTIDA,LTIDAP,LTIDT,LTIST)=""
- +2 SET LTI=$ORDER(@HDIV@(O10143,"LPI",LPI,"LTI",LTI))
- IF 'LTI
- QUIT
- +3 SET B=$GET(@HDIV@(O10143,"LPI",LPI,"LTI",LTI,1))
- SET LTIEN=$PIECE(B,U,1)
- SET LTINM=$PIECE(B,U,2)
- SET LTITYP=$PIECE(B,U,3)
- +4 SET LTIDA=$PIECE(B,U,4)
- SET LTIDAP=$PIECE(B,U,5)
- SET LTIDT=$PIECE(B,U,6)
- SET LTIST=$PIECE(B,U,7)
- +5 QUIT
- +6 ;
- GETLTS ; get lab specimen and mltf item
- +1 SET (LTSIEN,LTSNM,LTSUN,LTSDT,LTSST,LTMIEN,LTMNM,LTMANM,LTMST,LTMLON,LTMCOM,LTMPRO,LTMTIM,LTMSPC,LTMSCA,LTMMET)=""
- +2 SET LTS=$ORDER(@HDIV@(O10143,"LPI",LPI,"LTI",LTI,"LTS",LTS))
- IF 'LTS
- QUIT
- +3 SET B=$GET(@HDIV@(O10143,"LPI",LPI,"LTI",LTI,"LTS",LTS,1))
- SET LTSIEN=$PIECE(B,U,1)
- SET LTSNM=$PIECE(B,U,2)
- SET LTSUN=$PIECE(B,U,3)
- +4 SET LTSDT=$PIECE(B,U,4)
- SET LTSST=$PIECE(B,U,5)
- +5 SET B=$GET(@HDIV@(O10143,"LPI",LPI,"LTI",LTI,"LTS",LTS,2))
- SET LTMIEN=$PIECE(B,U,1)
- SET LTMNM=$PIECE(B,U,2)
- SET LTMANM=$PIECE(B,U,3)
- +6 SET LTMDT=$PIECE(B,U,4)
- +7 SET B=$GET(@HDIV@(O10143,"LPI",LPI,"LTI",LTI,"LTS",LTS,3))
- SET LTMST=$PIECE(B,U,1)
- SET LTMLON=$PIECE(B,U,2)
- SET LTMCOM=$PIECE(B,U,3)
- SET LTMPRO=$PIECE(B,U,4)
- +8 SET B=$GET(@HDIV@(O10143,"LPI",LPI,"LTI",LTI,"LTS",LTS,4))
- SET LTMTIM=$PIECE(B,U,1)
- SET LTMSPC=$PIECE(B,U,2)
- SET LTMSCA=$PIECE(B,U,3)
- SET LTMMET=$PIECE(B,U,4)
- +9 QUIT
- +10 ;
- CHAR(A) ; check for ctrl chars, <, >, &
- +1 NEW B,C,D,I,L,M,N
- +2 IF A=""
- QUIT A
- +3 SET D=A
- +4 ;<
- IF A["'AND'"
- Begin DoDot:1
- +5 SET B=$FIND(A,"'AND'")
- +6 SET A=$EXTRACT(A,1,(B-6))_"&"_$EXTRACT(A,B,$LENGTH(A))
- End DoDot:1
- +7 ;<
- IF A["'LESS THAN'"
- Begin DoDot:1
- +8 SET B=$FIND(A,"'LESS THAN'")
- +9 SET A=$EXTRACT(A,1,(B-12))_"<"_$EXTRACT(A,B,$LENGTH(A))
- End DoDot:1
- +10 ;<
- IF A["'GREATER THAN'"
- Begin DoDot:1
- +11 SET B=$FIND(A,"'GREATER THAN'")
- +12 SET A=$EXTRACT(A,1,(B-15))_">"_$EXTRACT(A,B,$LENGTH(A))
- End DoDot:1
- +13 ;<
- IF A["'FORWARD SLASH'"
- Begin DoDot:1
- +14 SET B=$FIND(A,"'FORWARD SLASH'")
- +15 SET A=$EXTRACT(A,1,(B-16))_"/"_$EXTRACT(A,B,$LENGTH(A))
- End DoDot:1
- +16 QUIT A
- +17 ;
- N(K) ;get value
- +1 NEW F
- +2 SET F=$PIECE($PIECE(K,"<",2),">",2)
- +3 QUIT F
- +4 ;
- XML ; entry if output is XML
- +1 USE IO
- +2 NEW A,B,C
- SET A=0
- +3 ; D RCHKC I QUIT Q
- FOR
- SET A=$ORDER(@RET1@(A))
- if 'A
- QUIT
- WRITE $GET(@RET1@(A)),!
- +4 KILL A,B,C
- +5 ;G PDONE
- +6 IF 'HDICRT
- DO ^%ZISC
- +7 QUIT
- +8 ;
- DISPL(S,F,E) ; display lines
- +1 NEW A,D
- +2 IF S=""
- QUIT
- +3 IF $LENGTH(S)<F
- WRITE S
- GOTO DISPL1
- +4 ;<
- SET D=F
- FOR
- if S=""
- QUIT
- SET A=""
- Begin DoDot:1
- +5 SET A=$EXTRACT(S,1,D)
- SET S=$EXTRACT(S,(D+1),$LENGTH(S))
- SET D=E
- +6 WRITE A
- IF S'=""
- WRITE " <"
- +7 DO RCHKC
- +8 if QUIT
- QUIT
- +9 IF S'=""
- WRITE !," > "
- End DoDot:1
- IF QUIT
- QUIT
- DISPL1 ;
- +1 IF QUIT
- QUIT
- +2 DO RCHKC
- if QUIT
- QUIT
- +3 ;