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

BLRNLINK.m

Go to the documentation of this file. 
  1. BLRNLINK ; IHS/HQT/MJL - LAB HOOK FOR APCDALV (PCC) ; 22-Oct-2013 09:22 ; MKK
  1.  ;;5.2;IHS LABORATORY;**1010,1011,1013,1024,1030,1033**;NOV 01, 1997
  1.  ;
  1.  ;; This routine makes use of the PCC MASTER CONTROL FILE
  1.  ;; The flag field of this file for the lab package contains the
  1.  ;; following:  1st piece - 0 = outpatient facility only
  1.  ;;                         1 = outpatient/inpatient facility
  1.  ;;
  1.  ;; THE FOLLOWING ARE NOT USED IN BLR 5.2
  1.  ;;             2nd piece - 0 = don't ask OP/IP prompt
  1.  ;;                         1 = ask OP/IP prompt
  1.  ;;             3rd piece - 0 = don't ask for ordering facility
  1.  ;;                         1 = ask for ordering facility
  1.  ;;             4th piece - 0 = don't pass clinic code
  1.  ;;                         1 = pass clinic code
  1.  ;; each piece is delimited by "~"
  1.  ;
  1. TSK ; entry point for background job
  1.  ;
  1.  ; D ENTRYAUD^BLRUTIL("TSK^BLRNLINK 0.0")
  1.  ;
  1.  Q:$P($G(^AUTTSITE(1,0)),U,8)'="Y"
  1.  S BLRQUIET=$G(BLRQUIET)
  1. START ;
  1.  ; D ENTRYAUD^BLRUTIL("START^BLRNLINK 0.0")
  1.  ;
  1.  S BLRQSITE=$P($G(^AUTTSITE(1,0)),U)
  1.  S APCDALVR("BLRLINK")=1
  1.  S BLRDH=$P($G(^BLRSITE(BLRQSITE,0)),U,6)
  1.  ; S:BLRDH="" BLRDH=+$H,$P(^BLRSITE(BLRQSITE,0),U,6)=BLRDH
  1.  ;
  1.  ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1033 
  1.  I $L(BLRQDH)'=5 D                        ; If BLRQDH an invalid number, reset it
  1.  . D MAKEITSO^BLRUTIL6
  1.  . S $P(^BLRSITE(BLRQSITE,0),U,6)=BLRDH
  1.  ; ----- END IHS/OIT/MKK - LR*5.2*1033 
  1.  ;
  1.  S BLR200CV=$P($P($G(^DD(9000010.09,1202,0)),U,2),"'")["P200"
  1.  S BLRLTP=+$P($G(^BLRSITE(BLRQSITE,21,BLRDH,0)),U,3)
  1.  ;
  1.  ; D ENTRYAUD^BLRUTIL("START^BLRNLINK 1.0","APCDALVR","DUZ")
  1.  ;
  1.  F  S BLRXPCC=$G(^BLRSITE(BLRQSITE,0)) D:BLRXPCC="" ERRMST S BLRLOG=$P(BLRXPCC,U,2),BLRSTOP=$P(BLRXPCC,U,9),BLRXPCC=$P(BLRXPCC,U,3) Q:'BLRXPCC!BLRSTOP  D  Q:BLRHCNT
  1.  .S APCDALVR("BLRLINK")=1,BLRERR=0,BLRBUL=0,BLRPCC="",BLRLTA=+$P($G(^BLRSITE(BLRQSITE,21,BLRDH,0)),U,2) S:'BLRLTA BLRLTP=0
  1.  .; D ENTRYAUD^BLRUTIL("START^BLRNLINK 1.1","APCDALVR")
  1.  .I BLRLOG S BLRX=$G(^BLRSITE(BLRQSITE,20,BLRQDH,0)) I $P(BLRX,U,2)>$P(BLRX,U,3) S BLRHCNT=1  Q
  1.  .I BLRLTP=BLRLTA S BLRHCNT=BLRHCNT+1  Q:BLRDH=+$H  S BLRHCNT=0,BLRDH=BLRDH+1,$P(^BLRSITE(BLRQSITE,0),U,6)=BLRDH,BLRLTP=0  Q
  1.  .S BLRLTP=BLRLTP+1,BLRHCNT=0
  1.  .S BLRLOGDA=$G(^BLRSITE(BLRQSITE,21,BLRDH,BLRLTP))
  1.  .Q:BLRLOGDA=""   ;IF NO EVENT ENTRY THEN JUST PASS IT UP
  1.  .S BLRDUZ2=$P($G(^BLRTXLOG(BLRLOGDA,0)),U,9)
  1.  .S:BLRDUZ2="" BLRDUZ2=$G(DUZ(2))
  1.  .;
  1.  .S (BLRORLDN,BLRORLDA)=""
  1.  .S BLRORLDZ=$P($G(^BLRTXLOG(BLRLOGDA,11)),U,6)
  1.  .S:$G(BLRORLDZ)'="" BLRORLDN=$P($G(^SC(BLRORLDZ,0)),U)    ;'NAME'
  1.  .S:$G(BLRORLDZ)'="" BLRORLDA=$P($G(^SC(BLRORLDZ,0)),U,2)  ;'ABBREVIATION'
  1.  .S:$G(BLRORLDZ)'="" BLRORLDZ=$P($G(^SC(BLRORLDZ,0)),U,4)  ;'INSTITUTION' 
  1.  .;
  1.  .;IF A MANUAL ACCESSION IS DONE 'BLRFILE' COULD BE THE FOLLOWING                
  1.  .;62.3      Lab Control Name 
  1.  .;67        Referral Patient 
  1.  .;67.1      Research 
  1.  .;67.2      Sterilizer 
  1.  .;67.3      Environmental 
  1.  .; 
  1.  .;IF BLRFILE IS NOT 2 (PATIENT) THEN DON'T SEND TO PCC 
  1.  .;AND DON'T SEND ERROR MESSAGES
  1.  .;
  1.  .;CHECK IF 'INSTITUTION' FIELD IS POPULATED IN THE 'HOSPITAL LOCATION'
  1.  .;CHECK FOR 'LAB LOG TO PCC' IS DONE IN BLRNFLTL IHS/ITSC/TPF 06/25/02
  1.  .;I $G(BLRORLDZ),$P($G(^BLRSITE(BLRORLDZ,0)),U,3) D PROC
  1.  .D PROC  ;IHS/ITSC/TPF 06/25/02
  1.  .I $G(BLRORLDZ)="",($G(BLRFILE)=2) S BLRBUL=1,BLRPCC="No INSTITUTION entry in the HOSPITAL LOCATION file: "_$G(BLRORLDN),BLRERR=1
  1.  .;
  1.  .;CHECK IF 'ABBREVIATION' FIELD IS POPULATED IN THE 'HOSPITAL LOCATION'
  1.  .;IF NOT SEND ERROR MESSAGE IHS/ITSC/TPF 06/25/02
  1.  .I $G(BLRORLDA)="",($G(BLRFILE)=2) S BLRBUL=1,BLRPCC="No ABBREVIATION entry in the HOSPITAL LOCATION file: "_$G(BLRORLDN),BLRERR=1
  1.  .D:BLRPCC'="" ERR
  1.  .; D:BLRBUL BULTNS
  1.  .D:BLRBUL BULTNS^BLRUTIL3   ; IHS/OIT/MKK - LR*5.2*1030
  1.  .S $P(^BLRSITE(BLRQSITE,21,BLRDH,0),U,3)=BLRLTP
  1.  .D CLNUP
  1.  ;
  1.  ; D ENTRYAUD^BLRUTIL("START^BLRNLINK 9.0")
  1.  D EOJ
  1.  Q
  1.  ;
  1. PROC ;
  1.  D ENTRYAUD^BLRUTIL("PROC^BLRNLINK 0.0","APCDALVR")
  1.  D ^BLRLINK1 Q:BLRERR
  1.  D ENTRYAUD^BLRUTIL("PROC^BLRNLINK 2.0","APCDALVR")   ; IHS/OIT/MKK - LR*5.2*1033
  1.  D ^BLRLINK2 Q:BLRERR
  1.  D ENTRYAUD^BLRUTIL("PROC^BLRNLINK 3.0","APCDALVR")   ; IHS/OIT/MKK - LR*5.2*1033
  1.  D ^BLRLINK3
  1.  D ENTRYAUD^BLRUTIL("PROC^BLRNLINK 9.0","APCDALVR")
  1.  Q
  1.  ;
  1.  ;ERROR IF NO 'BLR MASTER CONTROL' FILE
  1. ERRMST ;
  1.  ; D ENTRYAUD^BLRUTIL("ERRMST^BLRLINK 0.0")
  1.  S BLRBUL=1,BLRPCC="No entry for site "_$P($G(^AUTTLOC(BLRQSITE,0)),U,2)_"(ien = "_$G(BLRQSITE)_") in 'BLR MASTER CONTROL' file.",BLRERR=1
  1.  D:BLRPCC'="" ERR
  1.  ; D:BLRBUL BULTNS
  1.  D:BLRBUL BULTNS^BLRUTIL3    ; IHS/OIT/MKK - LR*5.2*1030
  1.  K BLRBUL,BLRPCC
  1.  Q
  1. ERR ; update transaction log with PCC error message value (if transaction is a modification then any previous value needs to be removed)
  1.  ; D ENTRYAUD^BLRUTIL("ERR^BLRNLINK 0.0")
  1.  K DIE,DA,DR
  1.  S DIE="^BLRTXLOG(",DA=BLRLOGDA,DR="106///^S X=BLRPCC"
  1.  D ^DIE Q
  1.  S BLRBUL=2,BLRPCC="Update to IHS transaction log to the PCC error flag field not done..REFILE"
  1.  W:'BLRQUIET !,"Another user is editing this file entry....update to IHS transaction log to the PCC error flag field not done"
  1.  Q
  1.  ;
  1. SETNUL ; update transaction log with PCC error message value (if transaction is a modification then any previous value needs to be removed)
  1.  ; D ENTRYAUD^BLRUTIL("SETNUL^BLRLINK 0.0")
  1.  K DIE,DA,DR
  1.  S DIE="^BLRTXLOG(",DA=BLRLOGDA,DR="106////@"
  1.  D ^DIE Q
  1.  S BLRBUL=2,BLRPCC="PCC error flag field not nulled."
  1.  W:'BLRQUIET !,"PCC error flag field not nulled"
  1.  Q
  1.  ;
  1. CALLDIK ;EP - DELETE PCC VISIT AND UPDATE BLRTXLOG
  1.  ; D ENTRYAUD^BLRUTIL("CALLDIK^BLRNLINK 0.0")
  1.  I '$L(BLRVIEN) S BLRPCC="Lab deleted test...PCC entries already deleted" D ERR^BLRLINK Q
  1.  N (BLRLOGDA,DA,DIK,DT,DUZ,U,DTIME,IO,IOSL,IOM,IOXY,IOST,XQDIC,XQPSM,XQY,XQYO,ZTQUEUED)
  1.  S BLRBUL=2,BLRPCC="Lab deleted test...PCC entries deleted"
  1.  D ^DIK,DTXVP
  1.  Q
  1.  ;
  1. DTXVP ; update transaction log to delete PCC file and v ien when lab deletes the test,
  1.  ; D ENTRYAUD^BLRUTIL("DTXVP^BLRNLINK 0.0")
  1.  ; or if PCC entries are missing.
  1.  K DIE,DA,DR
  1.  S DIE="^BLRTXLOG(",DA=BLRLOGDA
  1.  S DR="104////@;105////@;106///^S X=BLRPCC"
  1.  D ^DIE Q
  1.  S BLRPCC=BLRPCC_"PCC error flag field not set.",BLRBUL=2
  1.  W:'BLRQUIET !,BLRPCC,!
  1.  Q
  1.  ;
  1. DEBUG ;
  1.  ; Used for debugging only -- called by ^BLRDBG
  1.  ;
  1.  S BLRERR=0,BLRPCC="",BLRQUIET=$G(BLRQUIET),BLR200CV=$P($P(^DD(9000010.09,1202,0),U,2),"'")["P200"
  1.  D PROC,ERR:BLRPCC'="",CLNUP,EOJ
  1.  Q
  1.  ;
  1. CLNUP ;
  1.  ; D ENTRYAUD^BLRUTIL("CLNUP^BLRNLINK 0.0")
  1.  K APCDALVR,BLR,BLRABNL,BLRACC,BLRANT,BLRANTN,BLRBILL,BLRBUL,BLRBTN,BLRCD,BLRCDT,BLRCLIN,BLRCLNAM,BLRCOM,BLRCOST,BLRCPT,BLRCPTST,BLRDFN,BLRDUZ,BLREPNM,BLRERR,BLREPRV,BLRERR,BLRFILE,BLRVFN
  1.  K BLRIEN,BLRLINK,BLRLIT,BLRLOGDA,BLRMOD,BLRNAME,BLRNCOM,BLRNMSPC,BLRODT,BLROPNM,BLROPRV,BLRORD,BLRORDL,BLRORG,BLRORGN,BLRPAREN,BLRPATCD,BLRPCC,BLRPMSG,BLRPNAM,BLRPROG,BLRRES,BLRRFH,BLRVFILE,BLRVGL,BLRVFN
  1.  K BLRORLDZ,BLRORDL1,BLRCOMPD,BLRCOLSP  ;IHS/DIR TUC/AAB 04/08/98
  1.  K BLRRFL,BLRROOT,BLRSDI,BLRSITE,BLRSNAM,BLRSS,BLRSTAGE,BLRSTAT,BLRSTR,BLRTLAB,BLRTLOG,BLRTNAM,BLRTRAN,BLRTXT,BLRUNIT,BLRVADFN,BLRVAL,BLRVCAT,BLRVFLD,BLRVIEN,BLRVPRV,BLRVSIT,BLRVSUB,BLRXFLG
  1.  Q
  1.  ;
  1. EOJ ;
  1.  ; D ENTRYAUD^BLRUTIL("EOJ^BLRNLINK 0.0")
  1.  I $D(ZTQUEUED) S ZTREQ="@"
  1.  K APCDALVR,PCCVISIT,INDX,BLR200CV,BLRLOGDA,BLRORD,BLRI,BLRDFN,BLRVADFN,BLRRES,BLRUNIT,BLRACC,BLRSITE,BLRERR,BLRABNL,BLRVAL
  1.  K BLRTLAB,BLRSS,BLRDFN,AUPNTALK,BLRNMSPC,BLRCDT,BLRCD,BLRCLIN,BLRPATCD,BLRORDL,BLREPRV,BLROPRV,BLREPNM,BLROPNM,BLRSNAM,BLRODT
  1.  K BLRDUZ,BLRTNAME,BLRXFLG,BLRTRAN,BLRSDI,BLRMOD,BLRL,XMB,BLRPCC,BLRVIEN,BLRPAREN,BLRRFH,BLRRFL
  1.  Q