- LRPXSXRA ;VA/SLC/PKR - Build indexes for Lab Anatomic Path. ; 17-Oct-2014 09:22 ; MKK
- ;;5.2;LAB SERVICE;**1030,1031,1034**;NOV 01, 1997;Build 88
- ;
- ;;VA LR Patch(s): 295
- ;
- Q
- ;===============================================================
- AP ; from LRPXSXRL
- ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
- ; RPMS Lab does not use Clinical Reminders.
- ; None of the following code will be used.
- ; Q
- ; ----- END IHS/OIT/MKK - LR*5.2*1030
- ;
- Q:'$$PATCH^BLRUTIL4("PXRM*1.5*12") ; IHS/MSC/MKK - LR*5.2*1031
- ;
- ;
- ;Build the indexes for LAB DATA - ANATOMIC PATHOLOGY.
- N ANUMS,DATE,DFN,END,ENTRIES,ETIOL,GLOBAL,I,II,III,ICD,ICDX,IND,ITEM
- N LRDFN,ORGAN,NE,NERROR,NODE,SNOMED,SPEC,START,SUB,SUBS,TEMP,TENP,TEXT
- K ANUMS
- ;Dont leave any old stuff around.
- S GLOBAL=$$GET1^DID(63,"","","GLOBAL NAME")_"""AP"")"
- S ENTRIES=$P(^LR(0),U,4)
- S TENP=ENTRIES/10
- S TENP=+$P(TENP,".",1)
- I TENP<1 S TENP=1
- D BMES^XPDUTL("Building indexes for LAB DATA - ANATOMIC PATH")
- S TEXT="There are "_ENTRIES_" entries to process."
- D MES^XPDUTL(TEXT)
- S START=$H
- S (IND,NE,NERROR)=0
- D AANUMS^LRPXSXRB(.ANUMS)
- S LRDFN=.9
- F S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1 D
- . S TEMP=$G(^LR(LRDFN,0))
- . I $P(TEMP,U,2)'=2 Q
- . S DFN=+$P(TEMP,U,3)
- . I LRDFN'=$$LRDFN^LRPXAPIU(DFN) Q
- . S IND=IND+1
- . I IND#TENP=0 D
- .. S TEXT="Processing entry "_IND
- .. D MES^XPDUTL(TEXT)
- . D CYEMSP(LRDFN,DFN,.ANUMS) ; cytology, electron microscopy, sugrical path
- . S DATE=$$DOD^LRPXAPIU(DFN) I 'DATE Q ; date of death
- . I '+$G(^LR(LRDFN,"AU")) Q ; date of autopsy
- . I '($P(^LR(LRDFN,"AU"),U,3)&($P(^("AU"),U,15))) Q ; autopsy comp/released
- . S SPEC=0
- . F S SPEC=$O(^LR(LRDFN,33,SPEC)) Q:SPEC<1 D
- .. I '$L($P($G(^LR(LRDFN,33,SPEC,0)),U)) Q
- .. S ITEM="A;S;1."_$$UP($P(^LR(LRDFN,33,SPEC,0),U))
- .. S NODE=LRDFN_";33;"_SPEC_";0"
- .. D APSET(DFN,ITEM,DATE,NODE)
- . S ICD=0
- . F S ICD=$O(^LR(LRDFN,80,ICD)) Q:ICD<1 D
- .. S ICDX=+$G(^LR(LRDFN,80,ICD,0))
- .. I 'ICDX Q
- .. S ITEM="A;I;"_ICDX
- .. S NODE=LRDFN_";80;"_ICD_";0"
- .. D APSET(DFN,ITEM,DATE,NODE)
- . S I=0
- . F S I=$O(^LR(LRDFN,"AY",I)) Q:I<1 D
- .. S ORGAN=+$G(^LR(LRDFN,"AY",I,0))
- .. I 'ORGAN Q
- .. S ITEM="A;O;"_ORGAN
- .. S NODE=LRDFN_";AY;"_I_";0"
- .. D APSET(DFN,ITEM,DATE,NODE)
- .. F SUBS="1D","2M","3F","4P" D
- ... S SUB=+SUBS
- ... S II=0
- ... F S II=$O(^LR(LRDFN,"AY",I,SUB,II)) Q:II<1 D
- .... S SNOMED=+$G(^LR(LRDFN,"AY",I,SUB,II,0))
- .... I 'SNOMED Q
- .... S ITEM="A;"_$E(SUBS,2)_";"_SNOMED
- .... S NODE=LRDFN_";AY;"_I_";"_SUB_";"_II_";0"
- .... D APSET(DFN,ITEM,DATE,NODE)
- .... I SUB'=2 Q
- .... S III=0
- .... F S III=$O(^LR(LRDFN,"AY",I,SUB,II,1,III)) Q:III<1 D
- ..... S ETIOL=+$G(^LR(LRDFN,"AY",I,SUB,II,1,III,0))
- ..... I 'ETIOL Q
- ..... S ITEM="A;E;"_ETIOL
- ..... S NODE=LRDFN_";AY;"_I_";"_SUB_";"_II_";1;"_III_";0"
- ..... D APSET(DFN,ITEM,DATE,NODE)
- S TEXT=NE_" LAB DATA (AP) results indexed."
- D MES^XPDUTL(TEXT)
- S END=$H
- ; D DETIME^PXRMSXRM(START,END) ; dbia 4113 ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
- D DETIME^PXRMSXRM(START,END) ; dbia 4113 ; IHS/MSC/MKK - LR*5.2*1031 - Put back in
- ;If there were errors send a message.
- ; I NERROR>0 D ERRMSG^PXRMSXRM(NERROR,GLOBAL) ; dbia 4113 ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
- I NERROR>0 D ERRMSG^PXRMSXRM(NERROR,GLOBAL) ; dbia 4113 ; IHS/MSC/MKK - LR*5.2*1031 - Put back in
- ;Send a MailMan message with the results.
- ; D COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR) ; dbia 4113 ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
- D COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR) ; dbia 4113 ; IHS/MSC/MKK - LR*5.2*1031 - Put back in
- Q
- ;
- CYEMSP(LRDFN,DFN,ANUMS) ;
- ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
- ; RPMS Lab does not use Clinical Reminders.
- ; None of the following code will be used.
- ; Q
- ; ----- END IHS/OIT/MKK - LR*5.2*1030
- ;
- Q:'$$PATCH^BLRUTIL4("PXRM*1.5*12") ; IHS/MSC/MKK - LR*5.2*1031
- ;
- ;
- N ACC,APSUB,DATE,ERR,I,ICD,ICDX,ITEM,LRIDT,NODE,ORGAN,PREP,SPEC
- N TEST,TESTS K TESTS
- F APSUB="CY","EM","SP" D
- . I '$D(^LR(LRDFN,APSUB,0)) Q
- . S LRIDT=0
- . F S LRIDT=$O(^LR(LRDFN,APSUB,LRIDT)) Q:LRIDT<1 D
- .. S DATE=+$G(^LR(LRDFN,APSUB,LRIDT,0))
- .. I 'DATE Q
- .. S DATE=9999999-LRIDT ; use for multiple entries on a date
- .. I '($P(^LR(LRDFN,APSUB,LRIDT,0),U,3)&($P(^(0),U,11))) Q
- .. S SPEC=0
- .. F S SPEC=$O(^LR(LRDFN,APSUB,LRIDT,.1,SPEC)) Q:SPEC<1 D
- ... I '$L($P($G(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,0)),U)) Q
- ... S ITEM="A;S;1."_$$UP($P(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,0),U))
- ... S NODE=LRDFN_";"_APSUB_";"_LRIDT_";.1;"_SPEC_";0"
- ... D APSET(DFN,ITEM,DATE,NODE)
- ... S PREP=0
- ... F S PREP=$O(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,1,PREP)) Q:PREP<1 D
- .... S TEST=0
- .... F S TEST=$O(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,1,PREP,1,TEST)) Q:TEST<1 D
- ..... S TEST=+$G(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,1,PREP,1,TEST,0))
- ..... I 'TEST Q
- ..... S ITEM="A;T;"_TEST
- ..... S NODE=LRDFN_";"_APSUB_";"_LRIDT_";.1;"_SPEC_";1;"_PREP_";1;"_TEST_";0"
- ..... D APSET(DFN,ITEM,DATE,NODE)
- .. ; S ACC=$P(^LR(LRDFN,APSUB,LRIDT,0),U,6) ; do not use tests from acc
- .. ; I $L(ACC) D
- .. ; . S NODE=LRDFN_";"_APSUB_";"_LRIDT_";0"
- .. ; . D ACC^LRPXSXRB(.TESTS,ACC,DATE,.ANUMS,.ERR)
- .. ; . I 'ERR D
- .. ; .. S TEST=0
- .. ; .. F S TEST=$O(TESTS(TEST)) Q:TEST<1 D
- .. ; ... S ITEM="A;T;"_TEST
- .. ; ... D APSET(DFN,ITEM,DATE,NODE)
- .. S ICD=0
- .. F S ICD=$O(^LR(LRDFN,APSUB,LRIDT,3,ICD)) Q:ICD<1 D
- ... S ICDX=+$G(^LR(LRDFN,APSUB,LRIDT,3,ICD,0))
- ... I 'ICDX Q
- ... S ITEM="A;I;"_ICDX
- ... S NODE=LRDFN_";"_APSUB_";"_LRIDT_";3;"_ICD_";0"
- ... D APSET(DFN,ITEM,DATE,NODE)
- .. S I=0
- .. F S I=$O(^LR(LRDFN,APSUB,LRIDT,2,I)) Q:I<1 D
- ... S ORGAN=+$G(^LR(LRDFN,APSUB,LRIDT,2,I,0))
- ... I 'ORGAN Q
- ... S ITEM="A;O;"_ORGAN
- ... S NODE=LRDFN_";"_APSUB_";"_LRIDT_";2;"_I_";0"
- ... D APSET(DFN,ITEM,DATE,NODE)
- ... D SNOMED(LRDFN,DFN,LRIDT,DATE,APSUB,I)
- Q
- ;
- SNOMED(LRDFN,DFN,LRIDT,DATE,APSUB,I) ;
- ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
- ; RPMS Lab does not use Clinical Reminders.
- ; None of the following code will be used.
- ; Q
- ; ----- END IHS/OIT/MKK - LR*5.2*1030
- ;
- Q:'$$PATCH^BLRUTIL4("PXRM*1.5*12") ; IHS/MSC/MKK - LR*5.2*1031
- ;
- N ETIOL,II,III,ITEM,NODE,SNOMED,SUB,SUBS
- F SUBS="1D","2M","3F","4P" D
- . S SUB=+SUBS
- . S II=0
- . F S II=$O(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II)) Q:II<1 D
- .. S SNOMED=+$G(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II,0))
- .. I 'SNOMED Q
- .. S ITEM="A;"_$E(SUBS,2)_";"_SNOMED
- .. S NODE=LRDFN_";"_APSUB_";"_LRIDT_";2;"_I_";"_SUB_";"_II_";0"
- .. D APSET(DFN,ITEM,DATE,NODE)
- .. I SUB'=2 Q
- .. S III=0
- .. F S III=$O(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II,1,III)) Q:III<1 D
- ... S ETIOL=+$G(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II,1,III,0))
- ... I 'ETIOL Q
- ... S ITEM="A;E;"_ETIOL
- ... S NODE=LRDFN_";"_APSUB_";"_LRIDT_";2;"_I_";"_SUB_";"_II_";1;"_III_";0"
- ... D APSET(DFN,ITEM,DATE,NODE)
- Q
- ;
- UP(X) Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- ;
- APSET(DFN,ITEM,DATE,NODE) ;
- ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
- ; RPMS Lab does not use Clinical Reminders.
- ; None of the following code will be used.
- ; Q
- ; ----- END IHS/OIT/MKK - LR*5.2*1030
- ;
- Q:'$$PATCH^BLRUTIL4("PXRM*1.5*12") ; IHS/MSC/MKK - LR*5.2*1031
- ;
- I '$P(ITEM,";",3) D
- . N ETEXT
- . S ETEXT=NODE_" missing test"
- . ; D ADDERROR^PXRMSXRM("LR(AP",ETEXT,.NERROR) ; dbia 4113 ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
- . D ADDERROR^PXRMSXRM("LR(AP",ETEXT,.NERROR) ; dbia 4113 ; IHS/MSC/MKK - LR*5.2*1031 - Put back in
- E D
- . D SLAB^LRPX(DFN,DATE,ITEM,NODE)
- . S NE=NE+1
- Q
- ;
- LRPXSXRA ;VA/SLC/PKR - Build indexes for Lab Anatomic Path. ; 17-Oct-2014 09:22 ; MKK
- +1 ;;5.2;LAB SERVICE;**1030,1031,1034**;NOV 01, 1997;Build 88
- +2 ;
- +3 ;;VA LR Patch(s): 295
- +4 ;
- +5 QUIT
- +6 ;===============================================================
- AP ; from LRPXSXRL
- +1 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
- +2 ; RPMS Lab does not use Clinical Reminders.
- +3 ; None of the following code will be used.
- +4 ; Q
- +5 ; ----- END IHS/OIT/MKK - LR*5.2*1030
- +6 ;
- +7 ; IHS/MSC/MKK - LR*5.2*1031
- IF '$$PATCH^BLRUTIL4("PXRM*1.5*12")
- QUIT
- +8 ;
- +9 ;
- +10 ;Build the indexes for LAB DATA - ANATOMIC PATHOLOGY.
- +11 NEW ANUMS,DATE,DFN,END,ENTRIES,ETIOL,GLOBAL,I,II,III,ICD,ICDX,IND,ITEM
- +12 NEW LRDFN,ORGAN,NE,NERROR,NODE,SNOMED,SPEC,START,SUB,SUBS,TEMP,TENP,TEXT
- +13 KILL ANUMS
- +14 ;Dont leave any old stuff around.
- +15 SET GLOBAL=$$GET1^DID(63,"","","GLOBAL NAME")_"""AP"")"
- +16 SET ENTRIES=$PIECE(^LR(0),U,4)
- +17 SET TENP=ENTRIES/10
- +18 SET TENP=+$PIECE(TENP,".",1)
- +19 IF TENP<1
- SET TENP=1
- +20 DO BMES^XPDUTL("Building indexes for LAB DATA - ANATOMIC PATH")
- +21 SET TEXT="There are "_ENTRIES_" entries to process."
- +22 DO MES^XPDUTL(TEXT)
- +23 SET START=$HOROLOG
- +24 SET (IND,NE,NERROR)=0
- +25 DO AANUMS^LRPXSXRB(.ANUMS)
- +26 SET LRDFN=.9
- +27 FOR
- SET LRDFN=$ORDER(^LR(LRDFN))
- IF LRDFN<1
- QUIT
- Begin DoDot:1
- +28 SET TEMP=$GET(^LR(LRDFN,0))
- +29 IF $PIECE(TEMP,U,2)'=2
- QUIT
- +30 SET DFN=+$PIECE(TEMP,U,3)
- +31 IF LRDFN'=$$LRDFN^LRPXAPIU(DFN)
- QUIT
- +32 SET IND=IND+1
- +33 IF IND#TENP=0
- Begin DoDot:2
- +34 SET TEXT="Processing entry "_IND
- +35 DO MES^XPDUTL(TEXT)
- End DoDot:2
- +36 ; cytology, electron microscopy, sugrical path
- DO CYEMSP(LRDFN,DFN,.ANUMS)
- +37 ; date of death
- SET DATE=$$DOD^LRPXAPIU(DFN)
- IF 'DATE
- QUIT
- +38 ; date of autopsy
- IF '+$GET(^LR(LRDFN,"AU"))
- QUIT
- +39 ; autopsy comp/released
- IF '($PIECE(^LR(LRDFN,"AU"),U,3)&($PIECE(^("AU"),U,15)))
- QUIT
- +40 SET SPEC=0
- +41 FOR
- SET SPEC=$ORDER(^LR(LRDFN,33,SPEC))
- IF SPEC<1
- QUIT
- Begin DoDot:2
- +42 IF '$LENGTH($PIECE($GET(^LR(LRDFN,33,SPEC,0)),U))
- QUIT
- +43 SET ITEM="A;S;1."_$$UP($PIECE(^LR(LRDFN,33,SPEC,0),U))
- +44 SET NODE=LRDFN_";33;"_SPEC_";0"
- +45 DO APSET(DFN,ITEM,DATE,NODE)
- End DoDot:2
- +46 SET ICD=0
- +47 FOR
- SET ICD=$ORDER(^LR(LRDFN,80,ICD))
- IF ICD<1
- QUIT
- Begin DoDot:2
- +48 SET ICDX=+$GET(^LR(LRDFN,80,ICD,0))
- +49 IF 'ICDX
- QUIT
- +50 SET ITEM="A;I;"_ICDX
- +51 SET NODE=LRDFN_";80;"_ICD_";0"
- +52 DO APSET(DFN,ITEM,DATE,NODE)
- End DoDot:2
- +53 SET I=0
- +54 FOR
- SET I=$ORDER(^LR(LRDFN,"AY",I))
- IF I<1
- QUIT
- Begin DoDot:2
- +55 SET ORGAN=+$GET(^LR(LRDFN,"AY",I,0))
- +56 IF 'ORGAN
- QUIT
- +57 SET ITEM="A;O;"_ORGAN
- +58 SET NODE=LRDFN_";AY;"_I_";0"
- +59 DO APSET(DFN,ITEM,DATE,NODE)
- +60 FOR SUBS="1D","2M","3F","4P"
- Begin DoDot:3
- +61 SET SUB=+SUBS
- +62 SET II=0
- +63 FOR
- SET II=$ORDER(^LR(LRDFN,"AY",I,SUB,II))
- IF II<1
- QUIT
- Begin DoDot:4
- +64 SET SNOMED=+$GET(^LR(LRDFN,"AY",I,SUB,II,0))
- +65 IF 'SNOMED
- QUIT
- +66 SET ITEM="A;"_$EXTRACT(SUBS,2)_";"_SNOMED
- +67 SET NODE=LRDFN_";AY;"_I_";"_SUB_";"_II_";0"
- +68 DO APSET(DFN,ITEM,DATE,NODE)
- +69 IF SUB'=2
- QUIT
- +70 SET III=0
- +71 FOR
- SET III=$ORDER(^LR(LRDFN,"AY",I,SUB,II,1,III))
- IF III<1
- QUIT
- Begin DoDot:5
- +72 SET ETIOL=+$GET(^LR(LRDFN,"AY",I,SUB,II,1,III,0))
- +73 IF 'ETIOL
- QUIT
- +74 SET ITEM="A;E;"_ETIOL
- +75 SET NODE=LRDFN_";AY;"_I_";"_SUB_";"_II_";1;"_III_";0"
- +76 DO APSET(DFN,ITEM,DATE,NODE)
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +77 SET TEXT=NE_" LAB DATA (AP) results indexed."
- +78 DO MES^XPDUTL(TEXT)
- +79 SET END=$HOROLOG
- +80 ; D DETIME^PXRMSXRM(START,END) ; dbia 4113 ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
- +81 ; dbia 4113 ; IHS/MSC/MKK - LR*5.2*1031 - Put back in
- DO DETIME^PXRMSXRM(START,END)
- +82 ;If there were errors send a message.
- +83 ; I NERROR>0 D ERRMSG^PXRMSXRM(NERROR,GLOBAL) ; dbia 4113 ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
- +84 ; dbia 4113 ; IHS/MSC/MKK - LR*5.2*1031 - Put back in
- IF NERROR>0
- DO ERRMSG^PXRMSXRM(NERROR,GLOBAL)
- +85 ;Send a MailMan message with the results.
- +86 ; D COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR) ; dbia 4113 ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
- +87 ; dbia 4113 ; IHS/MSC/MKK - LR*5.2*1031 - Put back in
- DO COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR)
- +88 QUIT
- +89 ;
- CYEMSP(LRDFN,DFN,ANUMS) ;
- +1 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
- +2 ; RPMS Lab does not use Clinical Reminders.
- +3 ; None of the following code will be used.
- +4 ; Q
- +5 ; ----- END IHS/OIT/MKK - LR*5.2*1030
- +6 ;
- +7 ; IHS/MSC/MKK - LR*5.2*1031
- IF '$$PATCH^BLRUTIL4("PXRM*1.5*12")
- QUIT
- +8 ;
- +9 ;
- +10 NEW ACC,APSUB,DATE,ERR,I,ICD,ICDX,ITEM,LRIDT,NODE,ORGAN,PREP,SPEC
- +11 NEW TEST,TESTS
- KILL TESTS
- +12 FOR APSUB="CY","EM","SP"
- Begin DoDot:1
- +13 IF '$DATA(^LR(LRDFN,APSUB,0))
- QUIT
- +14 SET LRIDT=0
- +15 FOR
- SET LRIDT=$ORDER(^LR(LRDFN,APSUB,LRIDT))
- IF LRIDT<1
- QUIT
- Begin DoDot:2
- +16 SET DATE=+$GET(^LR(LRDFN,APSUB,LRIDT,0))
- +17 IF 'DATE
- QUIT
- +18 ; use for multiple entries on a date
- SET DATE=9999999-LRIDT
- +19 IF '($PIECE(^LR(LRDFN,APSUB,LRIDT,0),U,3)&($PIECE(^(0),U,11)))
- QUIT
- +20 SET SPEC=0
- +21 FOR
- SET SPEC=$ORDER(^LR(LRDFN,APSUB,LRIDT,.1,SPEC))
- IF SPEC<1
- QUIT
- Begin DoDot:3
- +22 IF '$LENGTH($PIECE($GET(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,0)),U))
- QUIT
- +23 SET ITEM="A;S;1."_$$UP($PIECE(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,0),U))
- +24 SET NODE=LRDFN_";"_APSUB_";"_LRIDT_";.1;"_SPEC_";0"
- +25 DO APSET(DFN,ITEM,DATE,NODE)
- +26 SET PREP=0
- +27 FOR
- SET PREP=$ORDER(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,1,PREP))
- IF PREP<1
- QUIT
- Begin DoDot:4
- +28 SET TEST=0
- +29 FOR
- SET TEST=$ORDER(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,1,PREP,1,TEST))
- IF TEST<1
- QUIT
- Begin DoDot:5
- +30 SET TEST=+$GET(^LR(LRDFN,APSUB,LRIDT,.1,SPEC,1,PREP,1,TEST,0))
- +31 IF 'TEST
- QUIT
- +32 SET ITEM="A;T;"_TEST
- +33 SET NODE=LRDFN_";"_APSUB_";"_LRIDT_";.1;"_SPEC_";1;"_PREP_";1;"_TEST_";0"
- +34 DO APSET(DFN,ITEM,DATE,NODE)
- End DoDot:5
- End DoDot:4
- End DoDot:3
- +35 ; S ACC=$P(^LR(LRDFN,APSUB,LRIDT,0),U,6) ; do not use tests from acc
- +36 ; I $L(ACC) D
- +37 ; . S NODE=LRDFN_";"_APSUB_";"_LRIDT_";0"
- +38 ; . D ACC^LRPXSXRB(.TESTS,ACC,DATE,.ANUMS,.ERR)
- +39 ; . I 'ERR D
- +40 ; .. S TEST=0
- +41 ; .. F S TEST=$O(TESTS(TEST)) Q:TEST<1 D
- +42 ; ... S ITEM="A;T;"_TEST
- +43 ; ... D APSET(DFN,ITEM,DATE,NODE)
- +44 SET ICD=0
- +45 FOR
- SET ICD=$ORDER(^LR(LRDFN,APSUB,LRIDT,3,ICD))
- IF ICD<1
- QUIT
- Begin DoDot:3
- +46 SET ICDX=+$GET(^LR(LRDFN,APSUB,LRIDT,3,ICD,0))
- +47 IF 'ICDX
- QUIT
- +48 SET ITEM="A;I;"_ICDX
- +49 SET NODE=LRDFN_";"_APSUB_";"_LRIDT_";3;"_ICD_";0"
- +50 DO APSET(DFN,ITEM,DATE,NODE)
- End DoDot:3
- +51 SET I=0
- +52 FOR
- SET I=$ORDER(^LR(LRDFN,APSUB,LRIDT,2,I))
- IF I<1
- QUIT
- Begin DoDot:3
- +53 SET ORGAN=+$GET(^LR(LRDFN,APSUB,LRIDT,2,I,0))
- +54 IF 'ORGAN
- QUIT
- +55 SET ITEM="A;O;"_ORGAN
- +56 SET NODE=LRDFN_";"_APSUB_";"_LRIDT_";2;"_I_";0"
- +57 DO APSET(DFN,ITEM,DATE,NODE)
- +58 DO SNOMED(LRDFN,DFN,LRIDT,DATE,APSUB,I)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +59 QUIT
- +60 ;
- SNOMED(LRDFN,DFN,LRIDT,DATE,APSUB,I) ;
- +1 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
- +2 ; RPMS Lab does not use Clinical Reminders.
- +3 ; None of the following code will be used.
- +4 ; Q
- +5 ; ----- END IHS/OIT/MKK - LR*5.2*1030
- +6 ;
- +7 ; IHS/MSC/MKK - LR*5.2*1031
- IF '$$PATCH^BLRUTIL4("PXRM*1.5*12")
- QUIT
- +8 ;
- +9 NEW ETIOL,II,III,ITEM,NODE,SNOMED,SUB,SUBS
- +10 FOR SUBS="1D","2M","3F","4P"
- Begin DoDot:1
- +11 SET SUB=+SUBS
- +12 SET II=0
- +13 FOR
- SET II=$ORDER(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II))
- IF II<1
- QUIT
- Begin DoDot:2
- +14 SET SNOMED=+$GET(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II,0))
- +15 IF 'SNOMED
- QUIT
- +16 SET ITEM="A;"_$EXTRACT(SUBS,2)_";"_SNOMED
- +17 SET NODE=LRDFN_";"_APSUB_";"_LRIDT_";2;"_I_";"_SUB_";"_II_";0"
- +18 DO APSET(DFN,ITEM,DATE,NODE)
- +19 IF SUB'=2
- QUIT
- +20 SET III=0
- +21 FOR
- SET III=$ORDER(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II,1,III))
- IF III<1
- QUIT
- Begin DoDot:3
- +22 SET ETIOL=+$GET(^LR(LRDFN,APSUB,LRIDT,2,I,SUB,II,1,III,0))
- +23 IF 'ETIOL
- QUIT
- +24 SET ITEM="A;E;"_ETIOL
- +25 SET NODE=LRDFN_";"_APSUB_";"_LRIDT_";2;"_I_";"_SUB_";"_II_";1;"_III_";0"
- +26 DO APSET(DFN,ITEM,DATE,NODE)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +27 QUIT
- +28 ;
- UP(X) QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- +1 ;
- APSET(DFN,ITEM,DATE,NODE) ;
- +1 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
- +2 ; RPMS Lab does not use Clinical Reminders.
- +3 ; None of the following code will be used.
- +4 ; Q
- +5 ; ----- END IHS/OIT/MKK - LR*5.2*1030
- +6 ;
- +7 ; IHS/MSC/MKK - LR*5.2*1031
- IF '$$PATCH^BLRUTIL4("PXRM*1.5*12")
- QUIT
- +8 ;
- +9 IF '$PIECE(ITEM,";",3)
- Begin DoDot:1
- +10 NEW ETEXT
- +11 SET ETEXT=NODE_" missing test"
- +12 ; D ADDERROR^PXRMSXRM("LR(AP",ETEXT,.NERROR) ; dbia 4113 ; IHS/OIT/MKK - LR*5.2*1030 - Commented out for XINDEX
- +13 ; dbia 4113 ; IHS/MSC/MKK - LR*5.2*1031 - Put back in
- DO ADDERROR^PXRMSXRM("LR(AP",ETEXT,.NERROR)
- End DoDot:1
- +14 IF '$TEST
- Begin DoDot:1
- +15 DO SLAB^LRPX(DFN,DATE,ITEM,NODE)
- +16 SET NE=NE+1
- End DoDot:1
- +17 QUIT
- +18 ;
