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

BLRLINK1.m

Go to the documentation of this file. 
  1. BLRLINK1 ;IHS/DIR/MJL - CONT. OF IHS LAB LINK TO PCC ; 17-Oct-2014 09:22 ; MKK
  1.  ;;5.2;IHS LABORATORY;**1008,1009,1015,1018,1021,1027,1030,1033,1034**;NOV 01, 1997;Build 88
  1.  ;
  1.  ; parsing of data elements from disk into local arrays and variables
  1.  ; validation of lab data to determine if appropriate to send to PCC
  1.  ;
  1.  ; BLRVAL = array containing elements of ^BLRTXLOG (file # 9009022)
  1.  ;
  1. EP ; EP
  1.  D ENTRYAUD^BLRUTIL("EP^BLRLINK1 0.0")
  1.  ;
  1.  D CHKBLRSS                            ; IHS/OIT/MKK - LR*5.2*1033
  1.  ;
  1.  S BLRVAL(0)=$G(^BLRTXLOG(BLRLOGDA,0))
  1.  S BLRVAL(1)=$G(^BLRTXLOG(BLRLOGDA,1))
  1.  S BLRVAL(2)=$G(^BLRTXLOG(BLRLOGDA,2))
  1.  S BLRVAL(3)=$G(^BLRTXLOG(BLRLOGDA,3))   ;IHS/ITSC/TPF 10/25/02 'SIGN OR SYMPTOM' LAB POV **1015**
  1.  ;
  1.  ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1027
  1.  D ENTRYAUD^BLRUTIL("EP^BLRLINK1 1.0","BLRVAL")
  1.  NEW IHSLPOV
  1.  ; Reset BLRVAL(3) if Sign or Symptom entry in BLRTXLOG contains an "^"
  1.  I $G(^BLRTXLOG(BLRLOGDA,3))["^" D
  1.  . S IHSLPOV=$P($G(^BLRTXLOG(BLRLOGDA,3)),"^",2)
  1.  . ; S:$G(IHSLABPOV)="" IHSLABPOV=$P($G(^BLRTXLOG(BLRLOGDA,3)),"^")
  1.  . S:$G(IHSLPOV)="" IHSLPOV="`"_$P($G(^BLRTXLOG(BLRLOGDA,3)),"^")  ; IHS/OIT/MKK - LR*5.2*1030
  1.  . S BLRVAL(3)=$G(IHSLPOV)
  1.  ;----- END IHS/OIT/MKK - LR*5.2*1027
  1.  ;
  1.  S BLRVAL(11)=$G(^BLRTXLOG(BLRLOGDA,11))
  1.  S BLRVAL(12)=$G(^BLRTXLOG(BLRLOGDA,12))
  1.  S BLRVAL(13)=$G(^BLRTXLOG(BLRLOGDA,13))
  1.  S BLRVAL(20)=$G(^BLRTXLOG(BLRLOGDA,20))
  1.  S BLRVAL(30)=$G(^BLRTXLOG(BLRLOGDA,30,0))  ;COMMENTS
  1.  ;
  1.  ; DO CHKINHL7  ; IHS/OIT/MKK - LR*5.2*1027
  1.  D CHKINHL7^BLRLINKU    ; IHS/OIT/MKK - LR*5.2*1030
  1.  ;
  1.  D ENTRYAUD^BLRUTIL("EP^BLRLINK1 5.0","BLRVAL")
  1.  F T=1:1 S TEXTSTR=$T(PARSE+T) S BLRSTR=$P(TEXTSTR,";",3) Q:BLRSTR=""  S NAME=$P(BLRSTR,"|"),INDX=$P(BLRSTR,"|",2),FLD=$P(BLRSTR,"|",3),@NAME=$P(BLRVAL(INDX),U,FLD)
  1.  ; S APCDALVR("APCDTLPV")=BLRLPOV  ;IHS/ITSC/TPF 9/24/02 LAB POV **1014**
  1.  ;
  1.  ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1027
  1.  ; NEW IHSLABPOV
  1.  ; I $G(BLRLPOV)["^" S IHSLABPOV=$P(BLRLPOV,"^",2)
  1.  ; S:$G(IHSLABPOV)="" IHSLABPOV=$P(BLRLPOV,"^")
  1.  ; S APCDALVR("APCDTLPV")=IHSLABPOV ; IHS/OIT/MKK LR*5.2*1027
  1.  ; ----- END IHS/OIT/MKK - LR*5.2*1027
  1.  ; S:$$ICDCHEK^BLRLINKU(BLRLPOV) APCDALVR("APCDTLPV")="`"_BLRLPOV
  1.  S APCDALVR("APCDTLPV")=$$GETCLINI(BLRLOGDA)
  1.  ; 
  1.  I BLRPCC'="" S BLRPCC="" D SETNUL^BLRLINK S BLRPCC="" ; reset error flag field in IHS transaction log file
  1.  I BLRSS="" S BLRBUL=2,BLRPCC="Test Subscript not defined",BLRERR=1 W:'BLRQUIET !,BLRPCC,! Q
  1.  ;
  1.  I BLR("SITE")="" S BLRBUL=2,BLRPCC="NO Institution entry",BLRERR=1 W:'BLRQUIET !,"There is no Institution entry in File #44 for this location",!,25,"V file not created" Q
  1.  S:BLRORDL'="" BLRORDL1=$P($G(^SC(BLRORDL,0)),U,4)  ;IHS/DIR TUC/AAB 04/08/98
  1.  S BLRORDL1=$G(BLRORDL1) I +BLRORDL1,BLR("SITE")'=BLRORDL1,BLRVIEN="" D SETTSITE ;IHS/DIR/MJL 09/20/99
  1.  I BLRFILE'=2 D  Q   ;if not a patient in file #2 then processing is not to occur
  1.  .S BLRBUL=$S($P($G(^BLRSITE(BLR("SITE"),0)),U,4):0,1:2)
  1.  .S BLRPCC="Record is from file "_BLRFILE_" - is not Patient File",BLRERR=1
  1.  .W:'BLRQUIET !,BLRPCC,!
  1.  I BLRVADFN="" S BLRBUL=2,BLRPCC="Patient IEN is required",BLRERR=1 W:'BLRQUIET !,BLRPCC,! Q
  1.  ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1021
  1.  I $D(^DPT(BLRVADFN))<10 D  Q     ; Make certain data exists in patient file
  1.  . S BLRBUL=2
  1.  . S BLRPCC="No Data in Patient File for IEN "_BLRVADFN
  1.  . S BLRERR=1
  1.  . W:'BLRQUIET !,BLRPCC,!
  1.  ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1021
  1.  I BLRCDT="",BLRSTAT'="O" S BLRBUL=2,BLRPCC="No Collection date",BLRERR=1 W:'BLRQUIET !,BLRPCC,! Q
  1.  ;
  1.  I BLRCDT\1>DT S BLRBUL=0,BLRPCC="Future collection - No update of PCC",BLRERR=1 W:'BLRQUIET !,BLRPCC,! Q  ;IHS/DIR/MJL 09/20/99
  1.  ;
  1.  S BLRNMSPC=$O(^DIC(9.4,"C","LR",""))
  1.  I '$D(^APCCCTRL(BLR("SITE"),11,BLRNMSPC,0)) S BLRBUL=2,BLRPCC="No Lab entry in PCC Master Control file for "_$P($G(^DIC(4,BLR("SITE"),0)),U),BLRERR=1 W:'BLRQUIET !,BLRPCC,! Q
  1.  S PCCVISIT=+BLRVIEN ; set up flag for visit creation
  1.  ;
  1. FAC ; EP
  1.  D ENTRYAUD^BLRUTIL("FAC^BLRLINK1 0.0")
  1.  S:BLRSDI="" BLRSDI="L"
  1.  ;
  1.  S:BLRCLIN'="" BLRCLIN="`"_BLRCLIN
  1.  S BLRCD=$P(BLRCDT,".")
  1.  ;
  1.  ; S BLRPATCD=BLRVADFN_$P(BLRODT,".")  ;IHS/OIRM TUC/MJL 11/07/2000
  1.  S BLRPATCD=BLRVADFN_$P(BLRCDT,".")    ; LR*5.2*1018 IHS -- Use Collection Date, not Order Date
  1.  I BLRVAL(30)'="" D LCOM
  1.  S SEX=$P($G(^DPT(BLRVADFN,0)),U,2),SEX=$S(SEX="":"",1:SEX),DOB=$P($G(^DPT(BLRVADFN,0)),U,3),AGE=$S($D(DT)&(DOB?7N):DT-DOB\10000,1:0)
  1.  S APCDALVR("APCDPAT")=BLRVADFN
  1.  S APCDALVR("APCDTYPE")=$S($P($G(^APCCCTRL(BLR("SITE"),0)),U,4)'="":$P($G(^(0)),U,4),1:"I")
  1.  S APCDALVR("APCDDATE")=BLRCD
  1.  S APCDALVR("APCDLOC")=BLR("SITE")
  1.  S APCDALVR("APCDCLN")=BLRCLIN
  1.  S APCDALVR("APCDTCLN")=BLRCLIN
  1.  S APCDALVR("APCDCAT")=BLRVCAT
  1.  D PROV Q:BLRERR
  1.  D:BLRSS'="CH" ^BLRSPRSE
  1.  D ENTRYAUD^BLRUTIL("FAC^BLRLINK1 9.0","APCDALVR","BLR")
  1.  Q
  1.  ;
  1. LCOM ; parse long comments
  1.  D ENTRYAUD^BLRUTIL("LCOM^BLRLINK1 0.0")
  1.  ;S BLRNCOM=$P(BLRVAL(30),U,4)
  1.  ;S:BLRNCOM>3 BLRNCOM=3
  1.  ;F BLRLCTR=1:1:BLRNCOM S BLRCOM=$G(^BLRTXLOG(BLRIEN,30,BLRLCTR,0)) D
  1.  ;. S BLRCOM(BLRLCTR)=$S($L(BLRCOM)>70:$E(BLRCOM,1,70),1:BLRCOM)
  1.  ;FOLLOWING ADDED BY MARK WILLIAMS **1014**
  1.  S BLRLCTR=0
  1.  S BLRCMDA=0 F  S BLRCMDA=$O(^BLRTXLOG(BLRIEN,30,BLRCMDA)) Q:'BLRCMDA  D
  1.  .S BLRLCTR=BLRLCTR+1
  1.  .S BLRCOM=$G(^BLRTXLOG(BLRIEN,30,BLRCMDA,0))
  1.  .S BLRCOM(BLRLCTR)=$E(BLRCOM,1,70)
  1.  ;END MARK WILLIAMS ADDITION
  1.  D ENTRYAUD^BLRUTIL("LCOM^BLRLINK1 9.0","BLRCOM")
  1.  Q
  1.  ;
  1. PROV ; check for provider location
  1.  D ENTRYAUD^BLRUTIL("PROV^BLRLINK1 0.0")
  1.  I +BLROPRV<1 S BLRBUL=2,BLRPCC="No entry in Provider file for the Ordering Provider",BLRERR=1 W:'BLRQUIET !,BLRPCC,! Q  ;IHS/DIR TUC/AAB 3/11/98
  1.  I BLROPRV'="",'BLR200CV S BLROPRV=$P($G(^VA(200,BLROPRV,0)),U,16) I BLROPRV="" S BLRBUL=2,BLRPCC="No entry in Provider file for the Ordering Provider",BLRERR=1 W:'BLRQUIET !,BLRPCC,! Q
  1.  I BLREPRV'="",'BLR200CV S BLREPRV=$P($G(^VA(200,BLREPRV,0)),U,16) I BLREPRV="" S BLRBUL=2,BLRPCC="No entry in Provider file for the Encounter Provider",BLRERR=1 W:'BLRQUIET !,BLRPCC,! Q
  1.  D ENTRYAUD^BLRUTIL("PROV^BLRLINK1 9.0")
  1.  Q
  1.  ;
  1. PARSE ;
  1.  ;;BLRIEN|0|1;; seq. # (IEN of transaction log file)
  1.  ;;BLRFILE|0|2;;
  1.  ;;BLRDFN|0|3;; patient's ^LR ien
  1.  ;;BLRVADFN|0|4;; patient pointer of IEN of patient file (file #2)
  1.  ;;BLRPNAM|0|5;; patient name
  1.  ;;BLRTLAB|0|6;; test/panel (ien)
  1.  ;;BLRTNAM|0|7;; test/panel name
  1.  ;;BLRSS|0|8;; lab module (CH,BB,MI,SP,AU,CY,OT)
  1.  ;;BLR("SITE")|0|9;; clinic's institution ien [DUZ(2)]
  1.  ;;BLRVCAT|0|10;; inpatient/outpatient category "I"= IP "A"= OP
  1.  ;;BLRPAREN|1|1;; parent pointer to IEN of transaction log file
  1.  ;;BLRSTAT|1|2;; order stat flag (O,R,M,D,A)
  1.  ;;BLREPRV|1|13;; encounter provider pointer (IEN of new person file)
  1.  ;;BLREPNM|1|14;; encounter provider name
  1.  ;;BLRVFN|1|4;; associated V file
  1.  ;;BLRVIEN|1|5;; ien of V file entry
  1.  ;;BLRPCC|1|6;; error flag
  1.  ;;BLRBILL|1|7;; billable item (1 = billable " " = nonbillable)
  1.  ;;BLRCOST|1|8;; lab test cost
  1.  ;;BLRCLIN|1|9;; clinic stop code
  1.  ;;BLRCLNAM|1|10;; clinic stop name
  1.  ;;BLRCPT|1|11;; CPT lab code pointer (IEN of file #9009021)
  1.  ;;BLRSDI|1|15;; source of data input (non-lab or lab)
  1.  ;;BLRCPTST|2|1;; billing CPT string
  1.  ;;BLRODT|11|1;; order date
  1.  ;;BLRORD|11|3;; order number
  1.  ;;BLROPRV|11|4;; ordering provider pointer (IEN of new person file)
  1.  ;;BLROPNM|11|5;; name of provider (used when provider pointer is null)
  1.  ;;BLRORDL|11|6;; clinic (ordering location)
  1.  ;;BLRCDT|12|1;; collected date/time
  1.  ;;BLRACC|12|2;; accession number
  1.  ;;BLRRES|20|1;; results
  1.  ;;BLRABNL|20|2;; result N/A flag
  1.  ;;BLRUNIT|20|3;; units
  1.  ;;BLRSITE|20|4;; site/specimen (ien of file #61)
  1.  ;;BLRSNAM|20|5;; site/specimen name
  1.  ;;BLRRFL|20|8;; reference low
  1.  ;;BLRRFH|20|9;; reference high
  1.  ;;BLRCOLSA|13|7;; collection sample
  1.  ;;BLRCOMDT|13|9;; complete date
  1.  ;;BLRLOINC|13|10;; loinc code pointer
  1.  ;;BLRLPOV|3|1;;  sign or symptom
  1.  ;;BLRLICD|13|11;;icd code pointer
  1.  ;
  1.  Q
  1.  ;;BLRPNARR|16|1;;provider narrative|     ; IHS/MSC/MKK - LR*5.2*1032
  1.  ;
  1. CHECK ; EP - CHECK MASTER CONTROL FILE
  1.  D ENTRYAUD^BLRUTIL("CHECK^BLRLINK1 0.0","BLR")
  1.  I '$D(^APCCCTRL(BLR("SITE"),0)) W:'BLRQUIET !,"The ordering facility is not an entry in the PCC Master Control File.",!,?25,"Visit not created" S BLRERR=1 Q
  1.  I '$D(^APCCCTRL(BLR("SITE"),11,BLRNMSPC,0)) W:'BLRQUIET !!,"Entry not made in the PCC Master Control File for Lab for this ordering location ",!,?25,"PCC Visit not created" S BLRERR=1 Q
  1.  I '$P($G(^APCCCTRL(BLR("SITE"),11,BLRNMSPC,0)),U,2) S BLRERR=1 ;; Pass data to PCC not set
  1.  D ENTRYAUD^BLRUTIL("CHECK^BLRLINK1 9.0","BLR")
  1.  Q
  1.  ;
  1. CKFRSTAT ; EP
  1.  D ENTRYAUD^BLRUTIL("CKFRSTAT^BLRLINK1 0.0")
  1.  S BLRQ=0,BLRCKP=0 F  Q:BLRQ  S BLRCKP=$O(^BLRTXLOG("AAT",BLRACC,BLRCKP)) Q:'BLRCKP  S BLRCKTN=0 F  S BLRCKTN=$O(^BLRTXLOG("AAT",BLRACC,BLRCKP,BLRCKTN)) Q:'BLRCKTN!BLRQ  D
  1.  .I $P($G(^BLRTXLOG(BLRCKTN,1)),U,5),BLRACC=$P($G(^BLRTXLOG(BLRCKTN,12)),U,2),BLRODT=$P($G(^BLRTXLOG(BLRCKTN,11)),U) S BLR("SITE")=$P($G(^BLRTXLOG(BLRCKTN,0)),U,9),BLRQ=1 Q
  1.  I BLRQ,BLR("SITE")=BLRORDL1 L +^BLRTXLOG(BLRIEN):60 S DIE=9009022,DA=BLRIEN,DR=".09////"_BLR("SITE") D ^DIE L -^BLRTXLOG(BLRIEN)
  1.  D ENTRYAUD^BLRUTIL("CKFRSTAT^BLRLINK1 9.0","BLR")
  1.  K BLRCKTN,BLRCKP,BLRQ
  1.  Q
  1.  ;
  1. SETTSITE ; EP
  1.  D ENTRYAUD^BLRUTIL("SETTSITE^BLRLINK1 0.0","BLR")
  1.  S BLR("SITE")=BLRORDL1
  1.  L +^BLRTXLOG(BLRIEN):60 S DIE=9009022,DA=BLRIEN,DR=".09////"_BLR("SITE") D ^DIE L -^BLRTXLOG(BLRIEN)
  1.  Q
  1.  ;
  1.  ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1033
  1. CHKBLRSS ; EP - Check to make sure Test Subscript is in the ^BLRTXLOG file
  1.  NEW F60PTR,F60BLRSS,STR,LOGBLRSS
  1.  ;
  1.  S STR=$G(^BLRTXLOG(BLRLOGDA,0))
  1.  S LOGBLRSS=$P(STR,"^",8)
  1.  ;
  1.  D ENTRYAUD^BLRUTIL("CHKBLRSS^BLRLINK1 1.0")
  1.  ;
  1.  Q:$L($G(BLRSS))&($L(LOGBLRSS))         ; If BLRSS & ^BLRTXLOG set, then quit
  1.  ;
  1.  ; At this point, either BLRSS or ^BLRTXLOG is null
  1.  ;
  1.  D ENTRYAUD^BLRUTIL("CHKBLRSS^BLRLINK1 2.0")
  1.  ;
  1.  ; If LOGBLRSS is valid and BLRSS is not, reset BLRSS and quit
  1.  I $L(LOGBLRSS)&($G(BLRSS)="") S BLRSS=LOGBLRSS  Q
  1.  ;
  1.  D ENTRYAUD^BLRUTIL("CHKBLRSS^BLRLINK1 3.0")
  1.  ;
  1.  ; If BLRSS is valid and ^BLRTXLOG is not, reset ^BLRTXLOG and quit
  1.  I $L($G(BLRSS))&($L(LOGBLRSS)<1)  S $P(^BLRTXLOG(BLRLOGDA,0),"^",8)=BLRSS
  1.  ;
  1.  ; At this point, both BLRSS and ^BLRTXLOG are null
  1.  ;
  1.  S F60PTR=+$P(STR,"^",6)
  1.  Q:F60PTR<1                         ; Skip if no Test pointer
  1.  ;
  1.  S F60BLRSS=$P($G(^LAB(60,F60PTR,0)),"^",4)
  1.  ;
  1.  D ENTRYAUD^BLRUTIL("CHKBLRSS^BLRLINK1 5.0")
  1.  ;
  1.  ; If F60BLRSS is valid, reset BLRSS and ^BLRTXLOG and then quit
  1.  I $L(F60BLRSS) D  Q
  1.  . S BLRSS=F60BLRSS
  1.  . S $P(^BLRTXLOG(BLRLOGDA,0),"^",8)=F60BLRSS
  1.  ;
  1.  Q
  1.  ;
  1.  ; Get Clinical Indication from Lab Order Entry File Using ^BLRTXLOG.
  1. GETCLINI(BLRLOGDA) ; EP
  1.  NEW CLININD,F60IEN,LRODT,LRODTST,LRSN
  1.  ;
  1.  S LRODT=$P(+$P($G(^BLRTXLOG(BLRLOGDA,11)),"^"),"."),LRSN=+$P($G(^(11)),"^",2),F60IEN=+$P($G(^(0)),"^",6)
  1.  S LRODTST=+$O(^LRO(69,LRODT,1,LRSN,2,"B",F60IEN,0))
  1.  S CLININD=$P($G(^LRO(69,LRODT,1,LRSN,2,LRODTST,9999999)),"^",2)
  1.  S:$L(CLININD)<1 CLININD=$P($G(^LRO(69,LRODT,1,LRSN,2,LRODTST,9999999)),"^")
  1.  S ^BLRTXLOG(BLRLOGDA,3)=CLININD    ; Reset IHS LAB TRANSACTION LOG file
  1.  Q CLININD
  1.  ; ----- END IHS/OIT/MKK - LR*5.2*1033