BQINIGH2 ;VNGT/HS/ALA-Continuation of the nightly job ; 19 Feb 2010 2:02 PM
;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
;
NGHT ;EP - Nightly Update of panels
NEW DA
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",3.19)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",3.21)=1
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
;
NEW USR,PNL,LGLOB,LOCK,BQINIGHT,PLIDEN,LFLG,CSTA
S BQINIGHT=1
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPLRF D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S USR=""
F S USR=$O(^BQICARE("AC","N",USR)) Q:'USR D
. ; Check for terminated users
. NEW TRMDT,TFL
. S TRMDT=+$P($G(^VA(200,USR,0)),U,11)
. I TRMDT S TFL=0 D Q:TFL
.. I TRMDT>DT Q
.. I TRMDT'>DT D FIX S TFL=1
. ;I ($P($G(^VA(200,USR,0)),U,11)'=""),(+$P($G(^VA(200,USR,0)),U,11)<DT)!($P($G(^VA(200,USR,0)),U,13)'="") D FIX Q
. ; Check for DISUSER (user has not signed on in a while)
. I $P($G(^VA(200,USR,0)),U,7)=1 D Q
.. NEW LOGIN,GUI
.. S LOGIN=$P($G(^BQICARE(USR,0)),U,6),GUI=$P(^(0),U,17)
.. I GUI'=$P(^BQI(90508,1,0),U,8) D FIX Q
.. I LOGIN="" D FIX Q
.. I ($E(DT,1,3)-$E(LOGIN,1,3)>0) D FIX Q
;
D ORD^BQIPLPU
NEW ORD,LKSUCC
S ORD=""
F S ORD=$O(^BQICARE("AF",ORD)) Q:ORD="" D
. S USR=""
. F S USR=$O(^BQICARE("AF",ORD,USR)) Q:USR="" D
.. S PNL=""
.. F S PNL=$O(^BQICARE("AF",ORD,USR,PNL)) Q:'PNL D
... ; For each panel, check current status, if currently running, quit
... S CSTA=+$$CSTA^BQIPLRF(USR,PNL) I CSTA Q
... ; Check what tasks are running
... ;D ^BQISYTSK
... S LKSUCC=0 D LOC(USR,PNL) I 'LKSUCC Q
... ; repopulate
... D POP^BQIPLPP("",USR,PNL,"",USR)
... ; Reset description
... NEW DA,IENS
... S DA(1)=USR,DA=PNL,IENS=$$IENS^DILF(.DA)
... K DESC
... ;D PEN^BQIPLDSC(USR,PNL,.DESC)
... D DESC^BQIPDSCM(USR,PNL,.DESC)
... D WP^DIE(90505.01,IENS,5,"","DESC")
... K DESC
... ; clear status
... D STA^BQIPLRF(USR,PNL)
... ; unlock panel
... D ULK^BQIPLRF(USR,PNL)
... ; unlock any panels that are filters
... D CPFLU^BQIPLUTL(USR,PNL)
... ; unlock any owning panels
... S PLIDEN=USR_$C(26)_$P(^BQICARE(USR,1,PNL,0),"^",1)
... I $D(^BQICARE("AD",PLIDEN)) D PFILU^BQIPLUTL(USR,PNL,PLIDEN)
;
NEW DA,BQTSK
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",3.2)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",3.21)="@"
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
F BQTSK="BQIAHOC","BQIBDP","BQIDCAPH","BQIDCASN","BQIPLLK","BQIPLPP","BQIPQMAN" K ^TMP(BQTSK,UID)
F BQTSK="BQIAHOC","BQIBDP","BQIDCAPH","BQIDCASN","BQIPLLK","BQIPLPP","BQIPQMAN" K ^TMP(UID,BQTSK)
Q
;
FIX ; Fix panels
NEW DA,IENS,BQIUPD
S DA(1)=USR,DA=""
F S DA=$O(^BQICARE("AC","N",USR,DA)) Q:DA="" D
. S IENS=$$IENS^DILF(.DA)
. S BQIUPD(90505.01,IENS,.06)="@"
D FILE^DIE("","BQIUPD","ERROR")
Q
;
LOC(USR,PNL) ;EP
K PLIDEN
S LOCK=$$LCK^BQIPLRF(USR,PNL)
; If not able to lock panel, clear status, send notification and go to next one
I 'LOCK D Q
. D STA^BQIPLRF(USR,PNL)
. D NNOTF^BQIPLRF(USR,PNL)
. ;
. ; Check if locked panel has panel filters
. NEW PLSUCC,SUBJECT,LOCK,POWNR,PPLIEN
. S PLSUCC=$$CPFL^BQIPLUTL(USR,PNL)
. ; If panel contains panel filters and were not successful in being locked,
. ; clear status, send notification and go to next panel in list
. I 'PLSUCC D Q
.. D STA^BQIPLRF(USR,PNL)
.. D ULK^BQIPLRF(USR,PNL)
.. S SUBJECT="Unable to lock panel(s) that are filters for panel: "_$P(^BQICARE(USR,1,PNL,0),U,1)
.. S LOCK="0^"_$P(PLSUCC,U,2),POWNR=$P(PLSUCC,U,4),PPLIEN=$P(PLSUCC,U,5)
.. I $P(PLSUCC,U,3)'="" S BMXSEC=$P(PLSUCC,U,3),SUBJECT=""
.. D NNOTF^BQIPLRF(USR,PNL,SUBJECT)
. ;
. ; Check if panel is a panel filter
. S PLIDEN=USR_$C(26)_$P(^BQICARE(USR,1,PNL,0),"^",1)
. I $D(^BQICARE("AD",PLIDEN)) D Q:LFLG
.. S LFLG=0 D PFILL^BQIPLUTL(USR,PNL,PLIDEN)
.. ; If not able to lock any of the owning panels, unlock owning panel, clear status, unlock panel and quit
.. I LFLG D PFILU^BQIPLUTL(USR,PNL,PLIDEN),STA^BQIPLRF(USR,PNL),ULK^BQIPLRF(USR,PNL)
. ; Set status to currently running
. D STA^BQIPLRF(USR,PNL,1)
S LKSUCC=1
Q
;
CMA ;EP - Do Community Alerts
NEW DA,BQTSK
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",3.16)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",3.18)=1
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQI1POJB D UNWIND^%ZTER"
D ^BQICALRT
D ^BQICASUI
NEW DA
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",3.17)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",3.18)="@"
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
F BQTSK="BQIALRTTMP","BQIPRCR","BQITAX","BQIALERT" K ^TMP(BQTSK,UID)
;
; Do Export
D ^BQICAEXP
;
; Clean up HL7 CANES messages
NEW MSGIEN,OLD,NODE,WHEN
S OLD=$$FMADD^XLFDT($$DT^XLFDT,-45)
S MSGIEN=0
F S MSGIEN=$O(^HLB(MSGIEN)) Q:'MSGIEN D
. S NODE=$G(^HLB(MSGIEN,0))
. I $P(NODE,U,5)'="CANES" Q
. S WHEN=$P(NODE,U,16)
. I WHEN="" D
.. NEW HLA
.. S HLA=$P(NODE,U,2)
.. S WHEN=$P($G(^HLA(HLA,0)),U,1)\1
. I WHEN,WHEN<OLD D DELETE^HLOPURGE(MSGIEN)
Q
;
ARM ;EP - Check and set up the 'ALL REMINDERS' Patient Health Summary Definition if needed
I '$$FIND1^DIC(9001015,"","","ALL REMINDERS","B","","") D
. N X,Y,DA,DR,DIC,DLAYGO,CMPNDX,REMNDX
. ;
. ; Create top level for 'ALL REMINDERS' Hlth Summary
. S X="ALL REMINDERS",DIC(0)="LZ",DLAYGO=9001015,DIC="^APCHSCTL("
. D FILE^DICN
. ;
. ; Build Sort Order Sub-File
. N DIC,DA,DIE,DR,X,BQIUPD
. S DLAYGO=9001015.01
. S (DA(1),REMNDX)=+Y,DA=10,DIC(0)="LZ",DIC="^APCHSCTL("_DA(1)_",1,"
. D FILE^DICN
. ;
. ; Add Component IEN for Reminders (from 9001016) to Hlth Summary
. S CMPNDX=$$FIND1^DIC(9001016,"","","HEALTH MAINTENANCE REMINDERS","B","","")
. Q:'CMPNDX
. S DA(1)=REMNDX,DA=10,DIE=DIC
. S DR=".01////"_DA_";1////"_CMPNDX
. D ^DIE
. ;
. ; Build Health Summary nodes.
. N DIC,DA,NDX,NDX2,RMNDR,X,Y,DR
. S DA(1)=REMNDX,DLAYGO=9001015.06,DIC(0)="LZ"
. S DIC="^APCHSCTL("_DA(1)_",5,"
. D FILE^DICN
. S NDX=""
. F S NDX=$O(^APCHSURV("AC",NDX)) Q:NDX="" D
.. S RMNDR=""
.. F S RMNDR=$O(^APCHSURV("AC",NDX,RMNDR)) Q:RMNDR="" D
... I $$GET1^DIQ(9001018,RMNDR,.07,"I")'="R" Q
... I $$GET1^DIQ(9001018,RMNDR,.03,"I")'="D" D
.... S (DA,NDX2)=(NDX*100)+RMNDR,DIE=DIC
.... S DR=".01////"_NDX2_";1////"_RMNDR
.... D ^DIE
.... Q
Q
;
PRN ;EP - Set up Prenatal lab tests
NEW TN
S TN=$O(^ATXLAB("B","BQI PRENATAL TAX","")) I TN="" Q
I $O(^ATXLAB(TN,21,0))="" Q
D LBT^BQIRGPG
Q
;
PED ;EP - Set up Pediatric lab tests
NEW TN
S TN=$O(^ATXLAB("B","BQI PEDIATRIC LAB TESTS","")) I TN="" Q
I $O(^ATXLAB(TN,21,0))="" Q
D LBT^BQIRGPD
Q
;
HCV ;EP - Set up HCV lab tests
NEW TN1,TN2
S TN1=$O(^ATXLAB("B","BQI HCV OTHER LAB TESTS",""))
S TN2=$O(^ATXLAB("B","BQI HCV BASELINE LAB TESTS",""))
I TN1="",TN2="" Q
I $O(^ATXLAB(TN1,21,0))="",$O(^ATXLAB(TN2,21,0))="" Q
D LBT^BQIRGHPC
Q
;
DMA ;EP - Set up DM Audit fields
NEW CMIEN
S CMIEN=$O(^BQI(90506.5,"B","DM Audit","")) I CMIEN="" Q
I $P(^BQI(90506.5,CMIEN,0),"^",10)=1 Q
D EN^BQIRGDMA
Q
;
IMM ;EP - Set up Immunizations
; Clean out immunizations
NEW DA,IENS
S DA=0,DA(1)=8
F S DA=$O(^BQI(90506.5,8,10,DA)) Q:'DA D
. S IENS=$$IENS^DILF(.DA)
. S BQIUPD(90506.51,IENS,.09)=1
D FILE^DIE("","BQIUPD","ERROR")
;
; Set up immunizations
NEW BN,CT,CD,INAC,DA,IENS,DIC,DESC
S BN=0
F S BN=$O(^AUTTIMM(BN)) Q:'BN D
. S INAC=$P(^AUTTIMM(BN,0),U,7)=1
. S NM=$P(^AUTTIMM(BN,0),U,2)
. S IEN=$O(^BQI(90506.5,8,10,"C",NM,""))
. I IEN'="" D
.. I INAC Q
.. S DA(1)=8,DA=IEN,IENS=$$IENS^DILF(.DA)
.. S BQIUPD(90506.51,IENS,.09)="@"
.. D FILE^DIE("","BQIUPD","ERROR")
.. S DESC(1)="Most recent immunization event is displayed."
.. D WP^DIE(90506.51,IENS,4,"","DESC")
. I IEN="" D
.. S CT=$P(^BQI(90506.5,8,10,0),U,3),CT=CT+1
.. S CD="I_"_$E("0000",$L(CT),2)_CT
.. S DA(1)=8,X=CD,DIC="^BQI(90506.5,"_DA(1)_",10,",DIC(0)="L",DLAYGO=90506.51
.. K DO,DD D FILE^DICN S DA=+Y
.. S IENS=$$IENS^DILF(.DA)
.. S BQIUPD(90506.51,IENS,.02)=8,BQIUPD(90506.51,IENS,.03)=NM
.. S BQIUPD(90506.51,IENS,.04)=BN,BQIUPD(90506.51,IENS,.05)="D"
.. S BQIUPD(90506.51,IENS,.06)="D",BQIUPD(90506.51,IENS,.08)="A"
.. D FILE^DIE("","BQIUPD","ERROR")
.. S DESC(1)="Most recent immunization event is displayed."
.. D WP^DIE(90506.51,IENS,4,"","DESC")
;
TBL ; Set up other tables
; Set up Cause of Death
NEW DN,CD
K ^XTMP("BQICOD")
S ^XTMP("BQICOD",0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"Cause of Death Values"
S DN=0
F S DN=$O(^AUPNPAT(DN)) Q:DN="" D
. S CD=$P($G(^AUPNPAT(DN,11)),U,14) I CD="" Q
. S ^XTMP("BQICOD",CD)=""
;
; Set up Language
NEW DN,LG,LAN
K ^XTMP("BQILANG")
S ^XTMP("BQILANG",0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"Preferred Language Values"
S DN=0
F S DN=$O(^AUPNPAT(DN)) Q:'DN D
. S LG=0
. F S LG=$O(^AUPNPAT(DN,86,LG)) Q:'LG D
.. S LAN=$P(^AUPNPAT(DN,86,LG,0),U,4) I LAN="" Q
.. S ^XTMP("BQILANG",LAN)=""
;
; Set up Divisions
I '$D(^XTMP("BQISYDIV")) D FND^BQISYDIV
;
; Set up POVs AND Snomeds
D JBB^BQINIGH3("POV")
D JBB^BQINIGH3("SNO")
Q
;
PRF ;EP - Communication Preference
NEW VFIEN,PFIEN,BI,TXT,QFL,CODE,DDATA,PDATA,NDATA,BQIX,NPDATA,NNDATA
S VFIEN=$O(^BQI(90506.3,"B","Patient Edit",""))
I VFIEN="" Q
S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC","REMMETH",""))
I PFIEN="" Q
S DDATA=$P($G(^DD(9000001,4002,0)),U,3),QFL=0
F BI=1:1:$L(DDATA,";") D
. S TXT=$P($P(DDATA,";",BI),":",2) I TXT="" Q
. I '$D(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",TXT)) S QFL=1
I QFL D
. NEW DA,DIK
. S DA(2)=VFIEN,DA(1)=PFIEN,DA=0,DIK="^BQI(90506.3,"_DA(2)_",10,"_DA(1)_",5,"
. F S DA=$O(^BQI(90506.3,DA(2),10,DA(1),5,DA)) Q:'DA D ^DIK
. F BI=1:1:$L(DDATA,";") D
.. S TXT=$P($P(DDATA,";",BI),":",2),CODE=$P($P(DDATA,";",BI),":",1)
.. NEW DA,DIC,X
.. S DA(2)=VFIEN,DA(1)=PFIEN,X=TXT
.. S DIC="^BQI(90506.3,"_DA(2)_",10,"_DA(1)_",5,",DIC(0)="L"
.. K DO,DD D FILE^DICN
.. S DA=+Y
.. NEW IENS
.. S IENS=$$IENS^DILF(.DA)
.. S BQIUPD(90506.315,IENS,.02)=CODE
.. D FILE^DIE("","BQIUPD","ERROR")
;
S PDATA=$P($G(^DD(90509.4,.02,0)),U,3)
S NDATA=$P($G(^DD(90509.4,.03,0)),U,3)
F BI=1:1:$L(DDATA,";") D
. S TXT=$P($P(DDATA,";",BI),":",2),CODE=$P($P(DDATA,";",BI),":",1)
. I CODE="" Q
. I TXT["NOT NOTIFY" Q
. S BQIX(CODE)=TXT
S OK=1 F BI=1:1:$L(PDATA,";") D
. S TXT=$P($P(PDATA,";",BI),":",2),CODE=$P($P(PDATA,";",BI),":",1)
. I CODE="" Q
. I $G(BQIX(CODE))=TXT Q
. S OK=0
I 'OK D
. S CODE="",NPDATA=""
. F S CODE=$O(BQIX(CODE)) Q:CODE="" S NPDATA=NPDATA_CODE_":"_BQIX(CODE)_";"
. S $P(^DD(90509.4,.02,0),U,3)=NPDATA
S OK=1 F BI=1:1:$L(NDATA,";") D
. S TXT=$P($P(NDATA,";",BI),":",2),CODE=$P($P(NDATA,";",BI),":",1)
. I CODE="" Q
. I $G(BQIX(CODE))=TXT Q
. S OK=0
I 'OK D
. S CODE="",NNDATA=""
. F S CODE=$O(BQIX(CODE)) Q:CODE="" S NNDATA=NNDATA_CODE_":"_BQIX(CODE)_";"
. S $P(^DD(90509.4,.03,0),U,3)=NNDATA
Q
BQINIGH2 ;VNGT/HS/ALA-Continuation of the nightly job ; 19 Feb 2010 2:02 PM
+1 ;;2.6;ICARE MANAGEMENT SYSTEM;;Jul 07, 2017;Build 72
+2 ;
NGHT ;EP - Nightly Update of panels
+1 NEW DA
+2 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+3 SET BQIUPD(90508,DA_",",3.19)=$$NOW^XLFDT()
+4 SET BQIUPD(90508,DA_",",3.21)=1
+5 DO FILE^DIE("","BQIUPD","ERROR")
+6 KILL BQIUPD
+7 ;
+8 NEW USR,PNL,LGLOB,LOCK,BQINIGHT,PLIDEN,LFLG,CSTA
+9 SET BQINIGHT=1
+10 ;
+11 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPLRF D UNWIND^%ZTER"
+12 ;
+13 SET USR=""
+14 FOR
SET USR=$ORDER(^BQICARE("AC","N",USR))
IF 'USR
QUIT
Begin DoDot:1
+15 ; Check for terminated users
+16 NEW TRMDT,TFL
+17 SET TRMDT=+$PIECE($GET(^VA(200,USR,0)),U,11)
+18 IF TRMDT
SET TFL=0
Begin DoDot:2
+19 IF TRMDT>DT
QUIT
+20 IF TRMDT'>DT
DO FIX
SET TFL=1
End DoDot:2
IF TFL
QUIT
+21 ;I ($P($G(^VA(200,USR,0)),U,11)'=""),(+$P($G(^VA(200,USR,0)),U,11)<DT)!($P($G(^VA(200,USR,0)),U,13)'="") D FIX Q
+22 ; Check for DISUSER (user has not signed on in a while)
+23 IF $PIECE($GET(^VA(200,USR,0)),U,7)=1
Begin DoDot:2
+24 NEW LOGIN,GUI
+25 SET LOGIN=$PIECE($GET(^BQICARE(USR,0)),U,6)
SET GUI=$PIECE(^(0),U,17)
+26 IF GUI'=$PIECE(^BQI(90508,1,0),U,8)
DO FIX
QUIT
+27 IF LOGIN=""
DO FIX
QUIT
+28 IF ($EXTRACT(DT,1,3)-$EXTRACT(LOGIN,1,3)>0)
DO FIX
QUIT
End DoDot:2
QUIT
End DoDot:1
+29 ;
+30 DO ORD^BQIPLPU
+31 NEW ORD,LKSUCC
+32 SET ORD=""
+33 FOR
SET ORD=$ORDER(^BQICARE("AF",ORD))
IF ORD=""
QUIT
Begin DoDot:1
+34 SET USR=""
+35 FOR
SET USR=$ORDER(^BQICARE("AF",ORD,USR))
IF USR=""
QUIT
Begin DoDot:2
+36 SET PNL=""
+37 FOR
SET PNL=$ORDER(^BQICARE("AF",ORD,USR,PNL))
IF 'PNL
QUIT
Begin DoDot:3
+38 ; For each panel, check current status, if currently running, quit
+39 SET CSTA=+$$CSTA^BQIPLRF(USR,PNL)
IF CSTA
QUIT
+40 ; Check what tasks are running
+41 ;D ^BQISYTSK
+42 SET LKSUCC=0
DO LOC(USR,PNL)
IF 'LKSUCC
QUIT
+43 ; repopulate
+44 DO POP^BQIPLPP("",USR,PNL,"",USR)
+45 ; Reset description
+46 NEW DA,IENS
+47 SET DA(1)=USR
SET DA=PNL
SET IENS=$$IENS^DILF(.DA)
+48 KILL DESC
+49 ;D PEN^BQIPLDSC(USR,PNL,.DESC)
+50 DO DESC^BQIPDSCM(USR,PNL,.DESC)
+51 DO WP^DIE(90505.01,IENS,5,"","DESC")
+52 KILL DESC
+53 ; clear status
+54 DO STA^BQIPLRF(USR,PNL)
+55 ; unlock panel
+56 DO ULK^BQIPLRF(USR,PNL)
+57 ; unlock any panels that are filters
+58 DO CPFLU^BQIPLUTL(USR,PNL)
+59 ; unlock any owning panels
+60 SET PLIDEN=USR_$CHAR(26)_$PIECE(^BQICARE(USR,1,PNL,0),"^",1)
+61 IF $DATA(^BQICARE("AD",PLIDEN))
DO PFILU^BQIPLUTL(USR,PNL,PLIDEN)
End DoDot:3
End DoDot:2
End DoDot:1
+62 ;
+63 NEW DA,BQTSK
+64 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+65 SET BQIUPD(90508,DA_",",3.2)=$$NOW^XLFDT()
+66 SET BQIUPD(90508,DA_",",3.21)="@"
+67 DO FILE^DIE("","BQIUPD","ERROR")
+68 KILL BQIUPD
+69 FOR BQTSK="BQIAHOC","BQIBDP","BQIDCAPH","BQIDCASN","BQIPLLK","BQIPLPP","BQIPQMAN"
KILL ^TMP(BQTSK,UID)
+70 FOR BQTSK="BQIAHOC","BQIBDP","BQIDCAPH","BQIDCASN","BQIPLLK","BQIPLPP","BQIPQMAN"
KILL ^TMP(UID,BQTSK)
+71 QUIT
+72 ;
FIX ; Fix panels
+1 NEW DA,IENS,BQIUPD
+2 SET DA(1)=USR
SET DA=""
+3 FOR
SET DA=$ORDER(^BQICARE("AC","N",USR,DA))
IF DA=""
QUIT
Begin DoDot:1
+4 SET IENS=$$IENS^DILF(.DA)
+5 SET BQIUPD(90505.01,IENS,.06)="@"
End DoDot:1
+6 DO FILE^DIE("","BQIUPD","ERROR")
+7 QUIT
+8 ;
LOC(USR,PNL) ;EP
+1 KILL PLIDEN
+2 SET LOCK=$$LCK^BQIPLRF(USR,PNL)
+3 ; If not able to lock panel, clear status, send notification and go to next one
+4 IF 'LOCK
Begin DoDot:1
+5 DO STA^BQIPLRF(USR,PNL)
+6 DO NNOTF^BQIPLRF(USR,PNL)
+7 ;
+8 ; Check if locked panel has panel filters
+9 NEW PLSUCC,SUBJECT,LOCK,POWNR,PPLIEN
+10 SET PLSUCC=$$CPFL^BQIPLUTL(USR,PNL)
+11 ; If panel contains panel filters and were not successful in being locked,
+12 ; clear status, send notification and go to next panel in list
+13 IF 'PLSUCC
Begin DoDot:2
+14 DO STA^BQIPLRF(USR,PNL)
+15 DO ULK^BQIPLRF(USR,PNL)
+16 SET SUBJECT="Unable to lock panel(s) that are filters for panel: "_$PIECE(^BQICARE(USR,1,PNL,0),U,1)
+17 SET LOCK="0^"_$PIECE(PLSUCC,U,2)
SET POWNR=$PIECE(PLSUCC,U,4)
SET PPLIEN=$PIECE(PLSUCC,U,5)
+18 IF $PIECE(PLSUCC,U,3)'=""
SET BMXSEC=$PIECE(PLSUCC,U,3)
SET SUBJECT=""
+19 DO NNOTF^BQIPLRF(USR,PNL,SUBJECT)
End DoDot:2
QUIT
+20 ;
+21 ; Check if panel is a panel filter
+22 SET PLIDEN=USR_$CHAR(26)_$PIECE(^BQICARE(USR,1,PNL,0),"^",1)
+23 IF $DATA(^BQICARE("AD",PLIDEN))
Begin DoDot:2
+24 SET LFLG=0
DO PFILL^BQIPLUTL(USR,PNL,PLIDEN)
+25 ; If not able to lock any of the owning panels, unlock owning panel, clear status, unlock panel and quit
+26 IF LFLG
DO PFILU^BQIPLUTL(USR,PNL,PLIDEN)
DO STA^BQIPLRF(USR,PNL)
DO ULK^BQIPLRF(USR,PNL)
End DoDot:2
IF LFLG
QUIT
+27 ; Set status to currently running
+28 DO STA^BQIPLRF(USR,PNL,1)
End DoDot:1
QUIT
+29 SET LKSUCC=1
+30 QUIT
+31 ;
CMA ;EP - Do Community Alerts
+1 NEW DA,BQTSK
+2 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+3 SET BQIUPD(90508,DA_",",3.16)=$$NOW^XLFDT()
+4 SET BQIUPD(90508,DA_",",3.18)=1
+5 DO FILE^DIE("","BQIUPD","ERROR")
+6 KILL BQIUPD
+7 NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQI1POJB D UNWIND^%ZTER"
+8 DO ^BQICALRT
+9 DO ^BQICASUI
+10 NEW DA
+11 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+12 SET BQIUPD(90508,DA_",",3.17)=$$NOW^XLFDT()
+13 SET BQIUPD(90508,DA_",",3.18)="@"
+14 DO FILE^DIE("","BQIUPD","ERROR")
+15 KILL BQIUPD
+16 FOR BQTSK="BQIALRTTMP","BQIPRCR","BQITAX","BQIALERT"
KILL ^TMP(BQTSK,UID)
+17 ;
+18 ; Do Export
+19 DO ^BQICAEXP
+20 ;
+21 ; Clean up HL7 CANES messages
+22 NEW MSGIEN,OLD,NODE,WHEN
+23 SET OLD=$$FMADD^XLFDT($$DT^XLFDT,-45)
+24 SET MSGIEN=0
+25 FOR
SET MSGIEN=$ORDER(^HLB(MSGIEN))
IF 'MSGIEN
QUIT
Begin DoDot:1
+26 SET NODE=$GET(^HLB(MSGIEN,0))
+27 IF $PIECE(NODE,U,5)'="CANES"
QUIT
+28 SET WHEN=$PIECE(NODE,U,16)
+29 IF WHEN=""
Begin DoDot:2
+30 NEW HLA
+31 SET HLA=$PIECE(NODE,U,2)
+32 SET WHEN=$PIECE($GET(^HLA(HLA,0)),U,1)\1
End DoDot:2
+33 IF WHEN
IF WHEN<OLD
DO DELETE^HLOPURGE(MSGIEN)
End DoDot:1
+34 QUIT
+35 ;
ARM ;EP - Check and set up the 'ALL REMINDERS' Patient Health Summary Definition if needed
+1 IF '$$FIND1^DIC(9001015,"","","ALL REMINDERS","B","","")
Begin DoDot:1
+2 NEW X,Y,DA,DR,DIC,DLAYGO,CMPNDX,REMNDX
+3 ;
+4 ; Create top level for 'ALL REMINDERS' Hlth Summary
+5 SET X="ALL REMINDERS"
SET DIC(0)="LZ"
SET DLAYGO=9001015
SET DIC="^APCHSCTL("
+6 DO FILE^DICN
+7 ;
+8 ; Build Sort Order Sub-File
+9 NEW DIC,DA,DIE,DR,X,BQIUPD
+10 SET DLAYGO=9001015.01
+11 SET (DA(1),REMNDX)=+Y
SET DA=10
SET DIC(0)="LZ"
SET DIC="^APCHSCTL("_DA(1)_",1,"
+12 DO FILE^DICN
+13 ;
+14 ; Add Component IEN for Reminders (from 9001016) to Hlth Summary
+15 SET CMPNDX=$$FIND1^DIC(9001016,"","","HEALTH MAINTENANCE REMINDERS","B","","")
+16 IF 'CMPNDX
QUIT
+17 SET DA(1)=REMNDX
SET DA=10
SET DIE=DIC
+18 SET DR=".01////"_DA_";1////"_CMPNDX
+19 DO ^DIE
+20 ;
+21 ; Build Health Summary nodes.
+22 NEW DIC,DA,NDX,NDX2,RMNDR,X,Y,DR
+23 SET DA(1)=REMNDX
SET DLAYGO=9001015.06
SET DIC(0)="LZ"
+24 SET DIC="^APCHSCTL("_DA(1)_",5,"
+25 DO FILE^DICN
+26 SET NDX=""
+27 FOR
SET NDX=$ORDER(^APCHSURV("AC",NDX))
IF NDX=""
QUIT
Begin DoDot:2
+28 SET RMNDR=""
+29 FOR
SET RMNDR=$ORDER(^APCHSURV("AC",NDX,RMNDR))
IF RMNDR=""
QUIT
Begin DoDot:3
+30 IF $$GET1^DIQ(9001018,RMNDR,.07,"I")'="R"
QUIT
+31 IF $$GET1^DIQ(9001018,RMNDR,.03,"I")'="D"
Begin DoDot:4
+32 SET (DA,NDX2)=(NDX*100)+RMNDR
SET DIE=DIC
+33 SET DR=".01////"_NDX2_";1////"_RMNDR
+34 DO ^DIE
+35 QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+36 QUIT
+37 ;
PRN ;EP - Set up Prenatal lab tests
+1 NEW TN
+2 SET TN=$ORDER(^ATXLAB("B","BQI PRENATAL TAX",""))
IF TN=""
QUIT
+3 IF $ORDER(^ATXLAB(TN,21,0))=""
QUIT
+4 DO LBT^BQIRGPG
+5 QUIT
+6 ;
PED ;EP - Set up Pediatric lab tests
+1 NEW TN
+2 SET TN=$ORDER(^ATXLAB("B","BQI PEDIATRIC LAB TESTS",""))
IF TN=""
QUIT
+3 IF $ORDER(^ATXLAB(TN,21,0))=""
QUIT
+4 DO LBT^BQIRGPD
+5 QUIT
+6 ;
HCV ;EP - Set up HCV lab tests
+1 NEW TN1,TN2
+2 SET TN1=$ORDER(^ATXLAB("B","BQI HCV OTHER LAB TESTS",""))
+3 SET TN2=$ORDER(^ATXLAB("B","BQI HCV BASELINE LAB TESTS",""))
+4 IF TN1=""
IF TN2=""
QUIT
+5 IF $ORDER(^ATXLAB(TN1,21,0))=""
IF $ORDER(^ATXLAB(TN2,21,0))=""
QUIT
+6 DO LBT^BQIRGHPC
+7 QUIT
+8 ;
DMA ;EP - Set up DM Audit fields
+1 NEW CMIEN
+2 SET CMIEN=$ORDER(^BQI(90506.5,"B","DM Audit",""))
IF CMIEN=""
QUIT
+3 IF $PIECE(^BQI(90506.5,CMIEN,0),"^",10)=1
QUIT
+4 DO EN^BQIRGDMA
+5 QUIT
+6 ;
IMM ;EP - Set up Immunizations
+1 ; Clean out immunizations
+2 NEW DA,IENS
+3 SET DA=0
SET DA(1)=8
+4 FOR
SET DA=$ORDER(^BQI(90506.5,8,10,DA))
IF 'DA
QUIT
Begin DoDot:1
+5 SET IENS=$$IENS^DILF(.DA)
+6 SET BQIUPD(90506.51,IENS,.09)=1
End DoDot:1
+7 DO FILE^DIE("","BQIUPD","ERROR")
+8 ;
+9 ; Set up immunizations
+10 NEW BN,CT,CD,INAC,DA,IENS,DIC,DESC
+11 SET BN=0
+12 FOR
SET BN=$ORDER(^AUTTIMM(BN))
IF 'BN
QUIT
Begin DoDot:1
+13 SET INAC=$PIECE(^AUTTIMM(BN,0),U,7)=1
+14 SET NM=$PIECE(^AUTTIMM(BN,0),U,2)
+15 SET IEN=$ORDER(^BQI(90506.5,8,10,"C",NM,""))
+16 IF IEN'=""
Begin DoDot:2
+17 IF INAC
QUIT
+18 SET DA(1)=8
SET DA=IEN
SET IENS=$$IENS^DILF(.DA)
+19 SET BQIUPD(90506.51,IENS,.09)="@"
+20 DO FILE^DIE("","BQIUPD","ERROR")
+21 SET DESC(1)="Most recent immunization event is displayed."
+22 DO WP^DIE(90506.51,IENS,4,"","DESC")
End DoDot:2
+23 IF IEN=""
Begin DoDot:2
+24 SET CT=$PIECE(^BQI(90506.5,8,10,0),U,3)
SET CT=CT+1
+25 SET CD="I_"_$EXTRACT("0000",$LENGTH(CT),2)_CT
+26 SET DA(1)=8
SET X=CD
SET DIC="^BQI(90506.5,"_DA(1)_",10,"
SET DIC(0)="L"
SET DLAYGO=90506.51
+27 KILL DO,DD
DO FILE^DICN
SET DA=+Y
+28 SET IENS=$$IENS^DILF(.DA)
+29 SET BQIUPD(90506.51,IENS,.02)=8
SET BQIUPD(90506.51,IENS,.03)=NM
+30 SET BQIUPD(90506.51,IENS,.04)=BN
SET BQIUPD(90506.51,IENS,.05)="D"
+31 SET BQIUPD(90506.51,IENS,.06)="D"
SET BQIUPD(90506.51,IENS,.08)="A"
+32 DO FILE^DIE("","BQIUPD","ERROR")
+33 SET DESC(1)="Most recent immunization event is displayed."
+34 DO WP^DIE(90506.51,IENS,4,"","DESC")
End DoDot:2
End DoDot:1
+35 ;
TBL ; Set up other tables
+1 ; Set up Cause of Death
+2 NEW DN,CD
+3 KILL ^XTMP("BQICOD")
+4 SET ^XTMP("BQICOD",0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"Cause of Death Values"
+5 SET DN=0
+6 FOR
SET DN=$ORDER(^AUPNPAT(DN))
IF DN=""
QUIT
Begin DoDot:1
+7 SET CD=$PIECE($GET(^AUPNPAT(DN,11)),U,14)
IF CD=""
QUIT
+8 SET ^XTMP("BQICOD",CD)=""
End DoDot:1
+9 ;
+10 ; Set up Language
+11 NEW DN,LG,LAN
+12 KILL ^XTMP("BQILANG")
+13 SET ^XTMP("BQILANG",0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"Preferred Language Values"
+14 SET DN=0
+15 FOR
SET DN=$ORDER(^AUPNPAT(DN))
IF 'DN
QUIT
Begin DoDot:1
+16 SET LG=0
+17 FOR
SET LG=$ORDER(^AUPNPAT(DN,86,LG))
IF 'LG
QUIT
Begin DoDot:2
+18 SET LAN=$PIECE(^AUPNPAT(DN,86,LG,0),U,4)
IF LAN=""
QUIT
+19 SET ^XTMP("BQILANG",LAN)=""
End DoDot:2
End DoDot:1
+20 ;
+21 ; Set up Divisions
+22 IF '$DATA(^XTMP("BQISYDIV"))
DO FND^BQISYDIV
+23 ;
+24 ; Set up POVs AND Snomeds
+25 DO JBB^BQINIGH3("POV")
+26 DO JBB^BQINIGH3("SNO")
+27 QUIT
+28 ;
PRF ;EP - Communication Preference
+1 NEW VFIEN,PFIEN,BI,TXT,QFL,CODE,DDATA,PDATA,NDATA,BQIX,NPDATA,NNDATA
+2 SET VFIEN=$ORDER(^BQI(90506.3,"B","Patient Edit",""))
+3 IF VFIEN=""
QUIT
+4 SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC","REMMETH",""))
+5 IF PFIEN=""
QUIT
+6 SET DDATA=$PIECE($GET(^DD(9000001,4002,0)),U,3)
SET QFL=0
+7 FOR BI=1:1:$LENGTH(DDATA,";")
Begin DoDot:1
+8 SET TXT=$PIECE($PIECE(DDATA,";",BI),":",2)
IF TXT=""
QUIT
+9 IF '$DATA(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",TXT))
SET QFL=1
End DoDot:1
+10 IF QFL
Begin DoDot:1
+11 NEW DA,DIK
+12 SET DA(2)=VFIEN
SET DA(1)=PFIEN
SET DA=0
SET DIK="^BQI(90506.3,"_DA(2)_",10,"_DA(1)_",5,"
+13 FOR
SET DA=$ORDER(^BQI(90506.3,DA(2),10,DA(1),5,DA))
IF 'DA
QUIT
DO ^DIK
+14 FOR BI=1:1:$LENGTH(DDATA,";")
Begin DoDot:2
+15 SET TXT=$PIECE($PIECE(DDATA,";",BI),":",2)
SET CODE=$PIECE($PIECE(DDATA,";",BI),":",1)
+16 NEW DA,DIC,X
+17 SET DA(2)=VFIEN
SET DA(1)=PFIEN
SET X=TXT
+18 SET DIC="^BQI(90506.3,"_DA(2)_",10,"_DA(1)_",5,"
SET DIC(0)="L"
+19 KILL DO,DD
DO FILE^DICN
+20 SET DA=+Y
+21 NEW IENS
+22 SET IENS=$$IENS^DILF(.DA)
+23 SET BQIUPD(90506.315,IENS,.02)=CODE
+24 DO FILE^DIE("","BQIUPD","ERROR")
End DoDot:2
End DoDot:1
+25 ;
+26 SET PDATA=$PIECE($GET(^DD(90509.4,.02,0)),U,3)
+27 SET NDATA=$PIECE($GET(^DD(90509.4,.03,0)),U,3)
+28 FOR BI=1:1:$LENGTH(DDATA,";")
Begin DoDot:1
+29 SET TXT=$PIECE($PIECE(DDATA,";",BI),":",2)
SET CODE=$PIECE($PIECE(DDATA,";",BI),":",1)
+30 IF CODE=""
QUIT
+31 IF TXT["NOT NOTIFY"
QUIT
+32 SET BQIX(CODE)=TXT
End DoDot:1
+33 SET OK=1
FOR BI=1:1:$LENGTH(PDATA,";")
Begin DoDot:1
+34 SET TXT=$PIECE($PIECE(PDATA,";",BI),":",2)
SET CODE=$PIECE($PIECE(PDATA,";",BI),":",1)
+35 IF CODE=""
QUIT
+36 IF $GET(BQIX(CODE))=TXT
QUIT
+37 SET OK=0
End DoDot:1
+38 IF 'OK
Begin DoDot:1
+39 SET CODE=""
SET NPDATA=""
+40 FOR
SET CODE=$ORDER(BQIX(CODE))
IF CODE=""
QUIT
SET NPDATA=NPDATA_CODE_":"_BQIX(CODE)_";"
+41 SET $PIECE(^DD(90509.4,.02,0),U,3)=NPDATA
End DoDot:1
+42 SET OK=1
FOR BI=1:1:$LENGTH(NDATA,";")
Begin DoDot:1
+43 SET TXT=$PIECE($PIECE(NDATA,";",BI),":",2)
SET CODE=$PIECE($PIECE(NDATA,";",BI),":",1)
+44 IF CODE=""
QUIT
+45 IF $GET(BQIX(CODE))=TXT
QUIT
+46 SET OK=0
End DoDot:1
+47 IF 'OK
Begin DoDot:1
+48 SET CODE=""
SET NNDATA=""
+49 FOR
SET CODE=$ORDER(BQIX(CODE))
IF CODE=""
QUIT
SET NNDATA=NNDATA_CODE_":"_BQIX(CODE)_";"
+50 SET $PIECE(^DD(90509.4,.03,0),U,3)=NNDATA
End DoDot:1
+51 QUIT
