BLRLINK ; IHS/DIR/FJE - LAB HOOK FOR APCDALV (PCC) ; 22-Oct-2013 09:22 ; MKK
;;5.2;LR;**1001,1003,1008,1019,1021,1024,1030,1033**;NOV 01, 1997
;
;; This routine makes use of the PCC MASTER CONTROL FILE
;; The flag field of this file for the lab package contains the
;; following: 1st piece - 0 = outpatient facility only
;; 1 = outpatient/inpatient facility
;;
;; THE FOLLOWING ARE NOT USED IN BLR5.2
;; 2nd piece - 0 = don't ask OP/IP prompt
;; 1 = ask OP/IP prompt
;; 3rd piece - 0 = don't ask for ordering facility
;; 1 = ask for ordering facility
;; 4th piece - 0 = don't pass clinic code
;; 1 = pass clinic code
;; each piece is delimited by "~"
;
TSK ; EP - entry point for background job -- EP is IHS/OIT/MKK 1021 Change
;
; D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER TSK^BLRLINK")
D ENTRYAUD^BLRUTIL("ENTER TSK^BLRLINK") ; IHS/OIT/MKK - LR*5.2*1033
L +^BLRLOCK:5 Q:'$T
Q:$P($G(^AUTTSITE(1,0)),U,8)'="Y"
S BLRQUIET=$G(BLRQUIET)
START ; EP
; D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER START^BLRLINK")
D ENTRYAUD^BLRUTIL("ENTER START^BLRLINK") ; IHS/OIT/MKK - LR*5.2*1033
S BLRQSITE=$P($G(^AUTTSITE(1,0)),U) ;IHS/DIR TUC/AAB 04/07/98
S APCDALVR("BLRLINK")=1
S BLRDH=$P($G(^BLRSITE(BLRQSITE,0)),U,6)
;----- BEGIN IHS MODIFICATIONS LR*5.2*1019 - IHS/OIT/MKK
; S BLR200CV=$P($P(^DD(9000010.09,1202,0),U,2),"'")="P200" ;IHS/DIR TUC/AAB 04/07/98
S BLR200CV=$P($P($G(^DD(9000010.09,1202,0)),U,2),"'")["P200"
;----- END IHS MODIFICATIONS LR*5.2*1019 - IHS/OIT/MKK
S:BLRDH="" BLRDH=+$H,$P(^BLRSITE(BLRQSITE,0),U,6)=BLRDH ;IHS/DIR TUC/AAB 04/07/98
S BLRLTP=+$P($G(^BLRSITE(BLRQSITE,21,BLRDH,0)),U,3),BLRHCNT=0 ;IHS/DIR TUC/AAB 04/07/98
;
F Q:'$P(^BLRSITE(BLRQSITE,0),U,3) D Q:BLRHCNT>600 H:BLRHCNT 1 ;IHS/DIR TUC/AAB 04/07/98
.S APCDALVR("BLRLINK")=1
.S BLRERR=0
.S BLRBUL=0
.S BLRPCC=""
.S BLRLTA=+$P($G(^BLRSITE(BLRQSITE,21,BLRDH,0)),U,2) S:'BLRLTA BLRLTP=0 ;IHS/DIR TUC/AAB 04/07/98
.I BLRLTP=BLRLTA D Q
.. S BLRHCNT=BLRHCNT+1 Q:BLRDH=+$H
.. S BLRHCNT=0
.. S BLRDH=BLRDH+1
.. S $P(^BLRSITE(BLRQSITE,0),U,6)=BLRDH
.. S BLRLTP=0 Q ;IHS/DIR TUC/AAB 04/07/98
.;
.S BLRLTP=BLRLTP+1
.S BLRHCNT=0
. ;----- BEGIN IHS MODIFICATIONS LR*5.2*1019 - IHS/OIT/MKK -- Get rid of Naked Reference
.; S BLRLOGDA=^BLRSITE(BLRQSITE,21,BLRDH,BLRLTP) ;IHS/DIR TUC/AAB 04/07/98
.S BLRLOGDA=$G(^BLRSITE(BLRQSITE,21,BLRDH,BLRLTP))
. ;----- END IHS MODIFICATIONS LR*5.2*1019 - IHS/OIT/MKK
.L +^BLRTXLOG(BLRLOGDA):60
.D PROC
.D:BLRPCC'="" ERR
.L -^BLRTXLOG(BLRLOGDA) ;IHS/OIRM TUC/MJL 5/21/98
.; D:BLRBUL BULTNS
.D:BLRBUL BULTNS^BLRUTIL3 ; IHS/OIT/MKK - LR*5.2*1030
.;S $P(^BLRSITE(DUZ(2),21,BLRDH,0),U,3)=BLRLTP
.S $P(^BLRSITE(BLRQSITE,21,BLRDH,0),U,3)=BLRLTP ;IHS/DIR TUC/AAB 04/07/98
.D CLNUP
D EOJ
L -^BLRLOCK
Q
;
PROC ; EP
; D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("PROC^BLRLINK 1.0")
D ENTRYAUD^BLRUTIL("PROC^BLRLINK 1.0","APCDALVR") ; IHS/OIT/MKK - LR*5.2*1033
;
D ^BLRLINK1 Q:BLRERR
D ENTRYAUD^BLRUTIL("PROC^BLRLINK 2.0","APCDALVR") ; IHS/OIT/MKK - LR*5.2*1033
D ^BLRLINK2 Q:BLRERR
D ENTRYAUD^BLRUTIL("PROC^BLRLINK 3.0","APCDALVR") ; IHS/OIT/MKK - LR*5.2*1033
D ^BLRLINK3
Q
;
;
ERR ; EP - update transaction log with PCC error message value (if transaction is a modification then any previous value needs to be removed)
K DIE,DA,DR
S DIE="^BLRTXLOG(",DA=BLRLOGDA,DR="106///^S X=BLRPCC"
D ^DIE Q
S BLRBUL=2,BLRPCC="Update to IHS transaction log to the PCC error flag field not done..REFILE"
W:'BLRQUIET !,"Another user is editing this file entry....update to IHS transaction log to the PCC error flag field not done"
Q
;
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
K DIE,DA,DR
S DIE="^BLRTXLOG(",DA=BLRLOGDA,DR="106////@"
D ^DIE Q
S BLRBUL=2,BLRPCC="PCC error flag field not nulled."
W:'BLRQUIET !,"PCC error flag field not nulled"
Q
;
CALLDIK ;EP - DELETE PCC VISIT AND UPDATE BLRTXLOG
; D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER CALLDIK^BLRLINK")
D ENTRYAUD^BLRUTIL("ENTER CALLDIK^BLRLINK") ; IHS/OIT/MKK - LR*5.2*1033
I '$L(BLRVIEN) S BLRPCC="Lab deleted test...PCC entries already deleted" D ERR^BLRLINK Q
N (BLRLOGDA,DA,DIK,DT,DUZ,U,DTIME,IO,IOSL,IOM,IOXY,IOST,XQDIC,XQPSM,XQY,XQYO,ZTQUEUED)
S BLRBUL=2,BLRPCC="Lab deleted test...PCC entries deleted"
D ^DIK,DTXVP
Q
;
DTXVP ; EP - update transaction log to delete PCC file and v ien when lab deletes the test,
; or if PCC entries are missing.
K DIE,DA,DR
S DIE="^BLRTXLOG(",DA=BLRLOGDA
S DR="104////@;105////@;106///^S X=BLRPCC"
D ^DIE Q
S BLRPCC=BLRPCC_"PCC error flag field not set.",BLRBUL=2
W:'BLRQUIET !,BLRPCC,!
Q
;
DEBUG ; EP
; Used for debugging only -- called by ^BLRDBG
;
S BLRERR=0,BLRPCC="",BLRQUIET=$G(BLRQUIET),BLR200CV=$P($P(^DD(9000010.09,1202,0),U,2),"'")="P200"
D PROC,ERR:BLRPCC'="",CLNUP,EOJ
Q
;
CLNUP ; EP
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
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
K BLRORDL1,BLRCOMPD,BLRCOLSP ;IHS/DIR TUC/AAB 04/08/98
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
Q
;
EOJ ; EP
I $D(ZTQUEUED) S ZTREQ="@"
K APCDALVR,PCCVISIT,INDX,BLR200CV,BLRLOGDA,BLRORD,BLRI,BLRDFN,BLRVADFN,BLRRES,BLRUNIT,BLRACC,BLRSITE,BLRERR,BLRABNL,BLRVAL
K BLRTLAB,BLRSS,BLRDFN,AUPNTALK,BLRNMSPC,BLRCDT,BLRCD,BLRCLIN,BLRPATCD,BLRORDL,BLREPRV,BLROPRV,BLREPNM,BLROPNM,BLRSNAM,BLRODT
K BLRDUZ,BLRTNAME,BLRXFLG,BLRTRAN,BLRSDI,BLRMOD,BLRL,XMB,BLRPCC,BLRVIEN,BLRPAREN,BLRRFH,BLRRFL
Q
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
+2 ;
+3 ;; This routine makes use of the PCC MASTER CONTROL FILE
+4 ;; The flag field of this file for the lab package contains the
+5 ;; following: 1st piece - 0 = outpatient facility only
+6 ;; 1 = outpatient/inpatient facility
+7 ;;
+8 ;; THE FOLLOWING ARE NOT USED IN BLR5.2
+9 ;; 2nd piece - 0 = don't ask OP/IP prompt
+10 ;; 1 = ask OP/IP prompt
+11 ;; 3rd piece - 0 = don't ask for ordering facility
+12 ;; 1 = ask for ordering facility
+13 ;; 4th piece - 0 = don't pass clinic code
+14 ;; 1 = pass clinic code
+15 ;; each piece is delimited by "~"
+16 ;
TSK ; EP - entry point for background job -- EP is IHS/OIT/MKK 1021 Change
+1 ;
+2 ; D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER TSK^BLRLINK")
+3 ; IHS/OIT/MKK - LR*5.2*1033
DO ENTRYAUD^BLRUTIL("ENTER TSK^BLRLINK")
+4 LOCK +^BLRLOCK:5
IF '$TEST
QUIT
+5 IF $PIECE($GET(^AUTTSITE(1,0)),U,8)'="Y"
QUIT
+6 SET BLRQUIET=$GET(BLRQUIET)
START ; EP
+1 ; D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER START^BLRLINK")
+2 ; IHS/OIT/MKK - LR*5.2*1033
DO ENTRYAUD^BLRUTIL("ENTER START^BLRLINK")
+3 ;IHS/DIR TUC/AAB 04/07/98
SET BLRQSITE=$PIECE($GET(^AUTTSITE(1,0)),U)
+4 SET APCDALVR("BLRLINK")=1
+5 SET BLRDH=$PIECE($GET(^BLRSITE(BLRQSITE,0)),U,6)
+6 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1019 - IHS/OIT/MKK
+7 ; S BLR200CV=$P($P(^DD(9000010.09,1202,0),U,2),"'")="P200" ;IHS/DIR TUC/AAB 04/07/98
+8 SET BLR200CV=$PIECE($PIECE($GET(^DD(9000010.09,1202,0)),U,2),"'")["P200"
+9 ;----- END IHS MODIFICATIONS LR*5.2*1019 - IHS/OIT/MKK
+10 ;IHS/DIR TUC/AAB 04/07/98
IF BLRDH=""
SET BLRDH=+$HOROLOG
SET $PIECE(^BLRSITE(BLRQSITE,0),U,6)=BLRDH
+11 ;IHS/DIR TUC/AAB 04/07/98
SET BLRLTP=+$PIECE($GET(^BLRSITE(BLRQSITE,21,BLRDH,0)),U,3)
SET BLRHCNT=0
+12 ;
+13 ;IHS/DIR TUC/AAB 04/07/98
FOR
IF '$PIECE(^BLRSITE(BLRQSITE,0),U,3)
QUIT
Begin DoDot:1
+14 SET APCDALVR("BLRLINK")=1
+15 SET BLRERR=0
+16 SET BLRBUL=0
+17 SET BLRPCC=""
+18 ;IHS/DIR TUC/AAB 04/07/98
SET BLRLTA=+$PIECE($GET(^BLRSITE(BLRQSITE,21,BLRDH,0)),U,2)
IF 'BLRLTA
SET BLRLTP=0
+19 IF BLRLTP=BLRLTA
Begin DoDot:2
+20 SET BLRHCNT=BLRHCNT+1
IF BLRDH=+$HOROLOG
QUIT
+21 SET BLRHCNT=0
+22 SET BLRDH=BLRDH+1
+23 SET $PIECE(^BLRSITE(BLRQSITE,0),U,6)=BLRDH
+24 ;IHS/DIR TUC/AAB 04/07/98
SET BLRLTP=0
QUIT
End DoDot:2
QUIT
+25 ;
+26 SET BLRLTP=BLRLTP+1
+27 SET BLRHCNT=0
+28 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1019 - IHS/OIT/MKK -- Get rid of Naked Reference
+29 ; S BLRLOGDA=^BLRSITE(BLRQSITE,21,BLRDH,BLRLTP) ;IHS/DIR TUC/AAB 04/07/98
+30 SET BLRLOGDA=$GET(^BLRSITE(BLRQSITE,21,BLRDH,BLRLTP))
+31 ;----- END IHS MODIFICATIONS LR*5.2*1019 - IHS/OIT/MKK
+32 LOCK +^BLRTXLOG(BLRLOGDA):60
+33 DO PROC
+34 IF BLRPCC'=""
DO ERR
+35 ;IHS/OIRM TUC/MJL 5/21/98
LOCK -^BLRTXLOG(BLRLOGDA)
+36 ; D:BLRBUL BULTNS
+37 ; IHS/OIT/MKK - LR*5.2*1030
IF BLRBUL
DO BULTNS^BLRUTIL3
+38 ;S $P(^BLRSITE(DUZ(2),21,BLRDH,0),U,3)=BLRLTP
+39 ;IHS/DIR TUC/AAB 04/07/98
SET $PIECE(^BLRSITE(BLRQSITE,21,BLRDH,0),U,3)=BLRLTP
+40 DO CLNUP
End DoDot:1
IF BLRHCNT>600
QUIT
IF BLRHCNT
HANG 1
+41 DO EOJ
+42 LOCK -^BLRLOCK
+43 QUIT
+44 ;
PROC ; EP
+1 ; D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("PROC^BLRLINK 1.0")
+2 ; IHS/OIT/MKK - LR*5.2*1033
DO ENTRYAUD^BLRUTIL("PROC^BLRLINK 1.0","APCDALVR")
+3 ;
+4 DO ^BLRLINK1
IF BLRERR
QUIT
+5 ; IHS/OIT/MKK - LR*5.2*1033
DO ENTRYAUD^BLRUTIL("PROC^BLRLINK 2.0","APCDALVR")
+6 DO ^BLRLINK2
IF BLRERR
QUIT
+7 ; IHS/OIT/MKK - LR*5.2*1033
DO ENTRYAUD^BLRUTIL("PROC^BLRLINK 3.0","APCDALVR")
+8 DO ^BLRLINK3
+9 QUIT
+10 ;
+11 ;
ERR ; EP - update transaction log with PCC error message value (if transaction is a modification then any previous value needs to be removed)
+1 KILL DIE,DA,DR
+2 SET DIE="^BLRTXLOG("
SET DA=BLRLOGDA
SET DR="106///^S X=BLRPCC"
+3 DO ^DIE
QUIT
+4 SET BLRBUL=2
SET BLRPCC="Update to IHS transaction log to the PCC error flag field not done..REFILE"
+5 IF 'BLRQUIET
WRITE !,"Another user is editing this file entry....update to IHS transaction log to the PCC error flag field not done"
+6 QUIT
+7 ;
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 KILL DIE,DA,DR
+2 SET DIE="^BLRTXLOG("
SET DA=BLRLOGDA
SET DR="106////@"
+3 DO ^DIE
QUIT
+4 SET BLRBUL=2
SET BLRPCC="PCC error flag field not nulled."
+5 IF 'BLRQUIET
WRITE !,"PCC error flag field not nulled"
+6 QUIT
+7 ;
CALLDIK ;EP - DELETE PCC VISIT AND UPDATE BLRTXLOG
+1 ; D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER CALLDIK^BLRLINK")
+2 ; IHS/OIT/MKK - LR*5.2*1033
DO ENTRYAUD^BLRUTIL("ENTER CALLDIK^BLRLINK")
+3 IF '$LENGTH(BLRVIEN)
SET BLRPCC="Lab deleted test...PCC entries already deleted"
DO ERR^BLRLINK
QUIT
+4 NEW (BLRLOGDA,DA,DIK,DT,DUZ,U,DTIME,IO,IOSL,IOM,IOXY,IOST,XQDIC,XQPSM,XQY,XQYO,ZTQUEUED)
+5 SET BLRBUL=2
SET BLRPCC="Lab deleted test...PCC entries deleted"
+6 DO ^DIK
DO DTXVP
+7 QUIT
+8 ;
DTXVP ; EP - update transaction log to delete PCC file and v ien when lab deletes the test,
+1 ; or if PCC entries are missing.
+2 KILL DIE,DA,DR
+3 SET DIE="^BLRTXLOG("
SET DA=BLRLOGDA
+4 SET DR="104////@;105////@;106///^S X=BLRPCC"
+5 DO ^DIE
QUIT
+6 SET BLRPCC=BLRPCC_"PCC error flag field not set."
SET BLRBUL=2
+7 IF 'BLRQUIET
WRITE !,BLRPCC,!
+8 QUIT
+9 ;
DEBUG ; EP
+1 ; Used for debugging only -- called by ^BLRDBG
+2 ;
+3 SET BLRERR=0
SET BLRPCC=""
SET BLRQUIET=$GET(BLRQUIET)
SET BLR200CV=$PIECE($PIECE(^DD(9000010.09,1202,0),U,2),"'")="P200"
+4 DO PROC
IF BLRPCC'=""
DO ERR
DO CLNUP
DO EOJ
+5 QUIT
+6 ;
CLNUP ; EP
+1 KILL 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
+2 KILL 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
+3 ;IHS/DIR TUC/AAB 04/08/98
KILL BLRORDL1,BLRCOMPD,BLRCOLSP
+4 KILL BLRRFL,BLRROOT,BLRSDI,BLRSITE,BLRSNAM,BLRSS,BLRSTAGE,BLRSTAT,BLRSTR,BLRTLAB,BLRTLOG,BLRTNAM,BLRTRAN,BLRTXT,BLRUNIT,BLRVADFN,BLRVAL,BLRVCAT,BLRVFLD,BLRVIEN,BLRVPRV,BLRVSIT,BLRVSUB,BLRXFLG
+5 QUIT
+6 ;
EOJ ; EP
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 KILL APCDALVR,PCCVISIT,INDX,BLR200CV,BLRLOGDA,BLRORD,BLRI,BLRDFN,BLRVADFN,BLRRES,BLRUNIT,BLRACC,BLRSITE,BLRERR,BLRABNL,BLRVAL
+3 KILL BLRTLAB,BLRSS,BLRDFN,AUPNTALK,BLRNMSPC,BLRCDT,BLRCD,BLRCLIN,BLRPATCD,BLRORDL,BLREPRV,BLROPRV,BLREPNM,BLROPNM,BLRSNAM,BLRODT
+4 KILL BLRDUZ,BLRTNAME,BLRXFLG,BLRTRAN,BLRSDI,BLRMOD,BLRL,XMB,BLRPCC,BLRVIEN,BLRPAREN,BLRRFH,BLRRFL
+5 QUIT
