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

BLRLINK.m

Go to the documentation of this file. 
  1. BLRLINK ; IHS/DIR/FJE - LAB HOOK FOR APCDALV (PCC) ; 22-Oct-2013 09:22 ; MKK
  1.  ;;5.2;LR;**1001,1003,1008,1019,1021,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 BLR5.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 ; EP - entry point for background job -- EP is IHS/OIT/MKK 1021 Change
  1.  ;
  1.  ; D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER TSK^BLRLINK")
  1.  D ENTRYAUD^BLRUTIL("ENTER TSK^BLRLINK")   ; IHS/OIT/MKK - LR*5.2*1033
  1.  L +^BLRLOCK:5 Q:'$T
  1.  Q:$P($G(^AUTTSITE(1,0)),U,8)'="Y"
  1.  S BLRQUIET=$G(BLRQUIET)
  1. START ; EP
  1.  ; D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER START^BLRLINK")
  1.  D ENTRYAUD^BLRUTIL("ENTER START^BLRLINK")     ; IHS/OIT/MKK - LR*5.2*1033
  1.  S BLRQSITE=$P($G(^AUTTSITE(1,0)),U)  ;IHS/DIR TUC/AAB 04/07/98
  1.  S APCDALVR("BLRLINK")=1
  1.  S BLRDH=$P($G(^BLRSITE(BLRQSITE,0)),U,6)
  1.  ;----- BEGIN IHS MODIFICATIONS LR*5.2*1019 - IHS/OIT/MKK
  1.  ; S BLR200CV=$P($P(^DD(9000010.09,1202,0),U,2),"'")="P200"  ;IHS/DIR TUC/AAB 04/07/98
  1.  S BLR200CV=$P($P($G(^DD(9000010.09,1202,0)),U,2),"'")["P200"
  1.  ;----- END IHS MODIFICATIONS LR*5.2*1019 - IHS/OIT/MKK
  1.  S:BLRDH="" BLRDH=+$H,$P(^BLRSITE(BLRQSITE,0),U,6)=BLRDH  ;IHS/DIR TUC/AAB 04/07/98
  1.  S BLRLTP=+$P($G(^BLRSITE(BLRQSITE,21,BLRDH,0)),U,3),BLRHCNT=0  ;IHS/DIR TUC/AAB 04/07/98
  1.  ;
  1.  F  Q:'$P(^BLRSITE(BLRQSITE,0),U,3)  D  Q:BLRHCNT>600  H:BLRHCNT 1  ;IHS/DIR TUC/AAB 04/07/98
  1.  .S APCDALVR("BLRLINK")=1
  1.  .S BLRERR=0
  1.  .S BLRBUL=0
  1.  .S BLRPCC=""
  1.  .S BLRLTA=+$P($G(^BLRSITE(BLRQSITE,21,BLRDH,0)),U,2) S:'BLRLTA BLRLTP=0  ;IHS/DIR TUC/AAB 04/07/98
  1.  .I BLRLTP=BLRLTA D  Q
  1.  .. S BLRHCNT=BLRHCNT+1 Q:BLRDH=+$H
  1.  .. S BLRHCNT=0
  1.  .. S BLRDH=BLRDH+1
  1.  .. S $P(^BLRSITE(BLRQSITE,0),U,6)=BLRDH
  1.  .. S BLRLTP=0 Q  ;IHS/DIR TUC/AAB 04/07/98
  1.  .;
  1.  .S BLRLTP=BLRLTP+1
  1.  .S BLRHCNT=0
  1.  . ;----- BEGIN IHS MODIFICATIONS LR*5.2*1019 - IHS/OIT/MKK -- Get rid of Naked Reference
  1.  .; S BLRLOGDA=^BLRSITE(BLRQSITE,21,BLRDH,BLRLTP)  ;IHS/DIR TUC/AAB 04/07/98
  1.  .S BLRLOGDA=$G(^BLRSITE(BLRQSITE,21,BLRDH,BLRLTP))
  1.  . ;----- END IHS MODIFICATIONS LR*5.2*1019 - IHS/OIT/MKK
  1.  .L +^BLRTXLOG(BLRLOGDA):60
  1.  .D PROC
  1.  .D:BLRPCC'="" ERR
  1.  .L -^BLRTXLOG(BLRLOGDA) ;IHS/OIRM TUC/MJL 5/21/98
  1.  .; D:BLRBUL BULTNS
  1.  .D:BLRBUL BULTNS^BLRUTIL3   ; IHS/OIT/MKK - LR*5.2*1030
  1.  .;S $P(^BLRSITE(DUZ(2),21,BLRDH,0),U,3)=BLRLTP
  1.  .S $P(^BLRSITE(BLRQSITE,21,BLRDH,0),U,3)=BLRLTP  ;IHS/DIR TUC/AAB 04/07/98
  1.  .D CLNUP
  1.  D EOJ
  1.  L -^BLRLOCK
  1.  Q
  1.  ;
  1. PROC ; EP
  1.  ; D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("PROC^BLRLINK 1.0")
  1.  D ENTRYAUD^BLRUTIL("PROC^BLRLINK 1.0","APCDALVR")   ; IHS/OIT/MKK - LR*5.2*1033
  1.  ;
  1.  D ^BLRLINK1 Q:BLRERR
  1.  D ENTRYAUD^BLRUTIL("PROC^BLRLINK 2.0","APCDALVR")   ; IHS/OIT/MKK - LR*5.2*1033
  1.  D ^BLRLINK2 Q:BLRERR
  1.  D ENTRYAUD^BLRUTIL("PROC^BLRLINK 3.0","APCDALVR")   ; IHS/OIT/MKK - LR*5.2*1033
  1.  D ^BLRLINK3
  1.  Q
  1.  ;
  1.  ;
  1. ERR ; EP - update transaction log with PCC error message value (if transaction is a modification then any previous value needs to be removed)
  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 ; EP - update transaction log with PCC error message value (if transaction is a modification then any previous value needs to be removed) -- EP is IHS/OIT/MKK - 1021 Change
  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:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER CALLDIK^BLRLINK")
  1.  D ENTRYAUD^BLRUTIL("ENTER CALLDIK^BLRLINK")   ; IHS/OIT/MKK - LR*5.2*1033
  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 ; EP - update transaction log to delete PCC file and v ien when lab deletes the test,
  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 ; EP 
  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 ; EP
  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 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 ; EP
  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