BQIPLPP ;PRXM/HC/ALA-Populate a panel based on definition ; 19 Oct 2005 12:26 PM
;;2.4;ICARE MANAGEMENT SYSTEM;**2**;Apr 01, 2015;Build 10
;
Q
;
POP(DATA,OWNR,PLIEN,KEEP,OVER) ;EP - BQI POPULATE PANEL
;
;Description
; Populate the patient list based on the panel definition
;Input
; OWNR - Owner of panel internal entry number
; PLIEN - Panel internal entry number
; KEEP - "N" if manual adds/removes should be 'removed' (any other value assumes "Y")
; OVER - User ien to replace DUZ (90505.01,3.5) if passed
;Output
; DATA = name of global (passed by reference) in which the data is stored
;
; NUMBER OF PATIENTS found if successful or BMXSEC if error.
; Final patient list should have been filed in node 40 of the panel.
;
; Check if share and has write access
I $G(BQINIGHT)="",'$$CKSHR^BQIPLSH(OWNR,PLIEN) S BMXSEC="You do not have write access" Q
;
NEW UID,II,TEMP
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP(UID,"BQIPLPP")),TEMP=$NA(^TMP(UID,"BQITEMP"))
K @DATA,@TEMP
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPLPP D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
NEW DA,IENS,TYPE,SOURCE,FSOURCE,PPIEN,PTYP,N,NN,PARMS,MPARMS
NEW EXEC,FEXEC,CNT,QMIEN,ANN,APARMS,MAPARMS
S KEEP=$G(KEEP)
S DA(1)=OWNR,DA=PLIEN,IENS=$$IENS^DILF(.DA),EXEC=""
S TYPE=$$GET1^DIQ(90505.01,IENS,.03,"I")
S SOURCE=$$GET1^DIQ(90505.01,IENS,.11,"E")
S FSOURCE=$$GET1^DIQ(90505.01,IENS,.14,"E")
S BQIUPD(90505.01,IENS,3.8)=$$NOW^XLFDT()
;
I TYPE="M" G DONE ; Manual type has no requirements for populate.
;
K PARMS,MPARMS
;
; Get parameters from panel definition
S N=0 F S N=$O(^BQICARE(OWNR,1,PLIEN,10,N)) Q:'N D
. NEW DA,IENS,NAME,VALUE
. S DA(2)=OWNR,DA(1)=PLIEN,DA=N,IENS=$$IENS^DILF(.DA)
. S NAME=$$GET1^DIQ(90505.02,IENS,.01,"E")
. S PTYP=$$PTYP^BQIDCDF(SOURCE,NAME)
. I PTYP="T" S VALUE=$$GET1^DIQ(90505.02,IENS,.03,"E")
. I PTYP'="T" S VALUE=$$GET1^DIQ(90505.02,IENS,.02,"E")
. I $E(VALUE,1,2)="T-" S VALUE=$$DATE^BQIUL1(VALUE)
. I VALUE'="",$O(^BQICARE(OWNR,1,PLIEN,10,N,2,0))="" S PARMS(NAME)=VALUE Q
. I VALUE'="",$O(^BQICARE(OWNR,1,PLIEN,10,N,2,0))'="" D Q
.. NEW AN
.. S AN=0,PARMS(NAME)=VALUE
.. F S AN=$O(^BQICARE(OWNR,1,PLIEN,10,N,2,AN)) Q:'AN D
... NEW DA,IENS,ANAME,AVALUE,APTYP
... S DA(3)=OWNR,DA(2)=PLIEN,DA(1)=N,DA=AN,IENS=$$IENS^DILF(.DA)
... S ANAME=$$GET1^DIQ(90505.22,IENS,.01,"E")
... S APTYP=$$PTYP^BQIDCDF(SOURCE,ANAME)
... I APTYP="T" S AVALUE=$$GET1^DIQ(90505.22,IENS,.03,"E")
... I APTYP'="T" S AVALUE=$$GET1^DIQ(90505.22,IENS,.02,"E")
... I $E(AVALUE,1,2)="T-" S AVALUE=$$DATE^BQIUL1(AVALUE)
... S PARMS(NAME)=$G(PARMS(NAME))_"^"_ANAME_"="_AVALUE_"^"
. ; If no single value, check for multiple values
. I VALUE="" D
.. Q:'$D(^BQICARE(OWNR,1,PLIEN,10,N,1))
.. S NN=0 F S NN=$O(^BQICARE(OWNR,1,PLIEN,10,N,1,NN)) Q:'NN D
... NEW AN,DA,IENS,VALUE
... S DA(3)=OWNR,DA(2)=PLIEN,DA(1)=N,DA=NN,IENS=$$IENS^DILF(.DA)
... I PTYP="T" S VALUE=$$GET1^DIQ(90505.21,IENS,.02,"E")
... I PTYP'="T" S VALUE=$$GET1^DIQ(90505.21,IENS,.01,"E")
... I $O(^BQICARE(OWNR,1,PLIEN,10,N,1,NN,2,0))="" S MPARMS(NAME,VALUE)="" Q
... S AN=0
... F S AN=$O(^BQICARE(OWNR,1,PLIEN,10,N,1,NN,2,AN)) Q:'AN D
.... NEW DA,IENS,ANAME,AVALUE,APTYP
.... S DA(4)=OWNR,DA(3)=PLIEN,DA(2)=N,DA(1)=NN,DA=AN,IENS=$$IENS^DILF(.DA)
.... S ANAME=$$GET1^DIQ(90505.212,IENS,.01,"E")
.... S APTYP=$$PTYP^BQIDCDF(SOURCE,ANAME)
.... I APTYP="T" S AVALUE=$$GET1^DIQ(90505.212,IENS,.03,"E")
.... I APTYP'="T" S AVALUE=$$GET1^DIQ(90505.212,IENS,.02,"E")
.... I $E(AVALUE,1,2)="T-" S AVALUE=$$DATE^BQIUL1(AVALUE)
.... S MPARMS(NAME,VALUE)=$G(MPARMS(NAME,VALUE))_ANAME_"="_AVALUE_"^"
;
I TYPE="Y" D G EXIT:$G(BMXSEC)]""
. ; Check if 'My Patients Definition' exists
. I '$O(^BQICARE(OWNR,7,0)) S BMXSEC="MY PATIENTS DEFINITION was not found" Q
. NEW DA,IENS
. S DA(1)=OWNR,DA=PLIEN,IENS=$$IENS^DILF(.DA)
. K DESC
. D DESC^BQIPDSCM(OWNR,PLIEN,.DESC)
. ;D PEN^BQIPLDSC(OWNR,PLIEN,.DESC)
. D WP^DIE(90505.01,IENS,5,"","DESC")
. K DESC
. S EXEC="D MYP^BQIPLPP"
;
I TYPE="Q" D G EXIT:$G(BMXSEC)'=""
. NEW FLAG,MTEXT
. S QMIEN=SOURCE
. I '$D(^DIBT(QMIEN)) D Q
.. S BMXSEC="QMAN template was not found"
.. S FLAG="" I $G(ZTSK)'="" S FLAG=1
.. S MTEXT(1,0)="The QMAN template used in panel "_$P(^BQICARE(OWNR,1,PLIEN,0),U,1)_" appears"
.. S MTEXT(2,0)="to have been deleted from your server. You will be unable to manually or automatically populate this panel."
.. D ADD^BQINOTF("",OWNR,BMXSEC,.MTEXT,FLAG)
. S EXEC="D QM^BQIPLPP",GLREF=$NA(^TMP(UID,"BQIPQMAN"))
;
I TYPE="P" D G EXIT:$G(BMXSEC)'=""
. ; Find predefined panel and get parameters
. S PPIEN=$$PP^BQIDCDF(SOURCE) I PPIEN=-1 S BMXSEC="Pre-defined panel type "_SOURCE_" was not found" Q
. S EXEC=$$GET1^DIQ(90506,PPIEN_",",2,"E")
;
S FGLOB=""
X EXEC
;
K PARMS,MPARMS
;
; If filters exist
I $O(^BQICARE(OWNR,1,PLIEN,15,0))'="" D FLT G EXIT:$G(BMXSEC)]""
;
; save the data returned after executable and filter applied
D SAVE(OWNR,PLIEN,GLREF,KEEP,$G(DCRIT))
;
DONE ;
K DA
S DA(1)=OWNR,DA=PLIEN,IENS=$$IENS^DILF(.DA)
;
S BQIUPD(90505.01,IENS,.07)=$$NOW^XLFDT()
S BQIUPD(90505.01,IENS,3.5)=$S($G(OVER):OVER,1:DUZ)
S BQIUPD(90505.01,IENS,3.9)=$$NOW^XLFDT()
D FILE^DIE("","BQIUPD")
;
S CNT=$$GET1^DIQ(90505.01,IENS,.1,"E")
I CNT="" S CNT=0
S II=II+1,@DATA@(II)="I00010NUMBER_OF_PATIENTS"_$C(30)
S II=II+1,@DATA@(II)=CNT_$C(30)
S II=II+1,@DATA@(II)=$C(31)
;
EXIT ;
K AGE,AUPNDAYS,AUPNDOB,AUPNDOD,AUPNPAT,AUPNSEX
K DFN,DOB,SEX,SSN,X,Y,BQIUPD,GLREF,FGLOB
Q
;
SAVE(OWNR,PLIEN,GLREF,KEEP,DCRIT) ;EP - Save patient list
;
; First delete any patient before saving
S DFN=0
F S DFN=$O(^BQICARE(OWNR,1,PLIEN,40,DFN)) Q:'DFN D
. NEW DA,IENS,STAT
. S DA(2)=OWNR,DA(1)=PLIEN,DA=DFN,IENS=$$IENS^DILF(.DA)
. I '$D(^DPT(DFN)) D DPT^BQIPLCR(DFN) Q
. ; if the patient was already 'added' or 'removed', quit unless KEEP is explicitly "N"
. S STAT=$$GET1^DIQ(90505.04,IENS,.02,"I")
. I STAT="A"!(STAT="R"),KEEP'="N" Q
. ; save off original patients
. S @TEMP@(DFN)=^BQICARE(OWNR,1,PLIEN,40,DFN,0)
. M @TEMP@(DFN,5)=^BQICARE(OWNR,1,PLIEN,40,DFN,5)
. ; otherwise, delete patient from panel
. D DPT^BQIPLCR(DFN)
;
S DFN=""
F S DFN=$O(@GLREF@(DFN)) Q:DFN="" D
. I '$D(^DPT(DFN)) Q
. ; if patient already in panel check for FLAG value
. I $D(^BQICARE(OWNR,1,PLIEN,40,DFN)) D Q
.. NEW DA,IENS,STAT
.. S DA(2)=OWNR,DA(1)=PLIEN,DA=DFN,IENS=$$IENS^DILF(.DA)
.. ; if the patient was already 'added' or 'removed', quit to preserve that value
.. S STAT=$$GET1^DIQ(90505.04,IENS,.02,"I")
.. I STAT="A"!(STAT="R") Q
. ; otherwise, add patient to panel
. D APT^BQIPLCR(DFN)
. I $D(@TEMP@(DFN)) S $P(^BQICARE(OWNR,1,PLIEN,40,DFN,0),U,7)=$P(@TEMP@(DFN),U,7)
;
; File any matched criteria
I $G(DCRIT)'="" D
. S CTYP=""
. F S CTYP=$O(@DCRIT@(CTYP)) Q:CTYP="" D
.. S DFN=""
.. F S DFN=$O(@DCRIT@(CTYP,DFN)) Q:DFN="" D APMTC^BQIPLCR(.DCRIT,.CTYP,.DFN)
;
; Count the saved records
D CNTP^BQIPLCR(OWNR,PLIEN)
K @TEMP
Q
;
QM ; Find DFNs in a QMAN search template
K @GLREF
NEW DFN,FILE,IEN
S FILE=$P($G(^DIBT(QMIEN,0)),U,4)
I FILE=9000001 D
. S DFN=0
. F S DFN=$O(^DIBT(QMIEN,1,DFN)) Q:'DFN S @GLREF@(DFN)=""
I FILE=9000010 D
. S IEN=0
. F S IEN=$O(^DIBT(QMIEN,1,IEN)) Q:'IEN D
.. I $P($G(^AUPNVSIT(IEN,0)),U,11)=1 Q
.. S DFN=$P($G(^AUPNVSIT(IEN,0)),U,5) Q:DFN=""
.. S @GLREF@(DFN)=""
Q
;
MYP ; Find DFNs using the MY PATIENTS DEFINITION
NEW MIEN,PIEN,PMIEN,DFN,MDATA
S MDATA=$NA(^TMP(UID,"BQIPMYP"))
K @MDATA
S MIEN=0
F S MIEN=$O(^BQICARE(OWNR,7,MIEN)) Q:'MIEN D
. NEW DA,IENS
. S DA(1)=OWNR,DA=MIEN,IENS=$$IENS^DILF(.DA)
. S SOURCE=$$GET1^DIQ(90505.07,IENS,.01,"E")
. S PPIEN=$$PP^BQIDCDF(SOURCE) I PPIEN=-1 Q
. S EXEC=$$GET1^DIQ(90506,PPIEN_",",2,"E")
. K PARMS,MPARMS
. S PIEN=0
. F S PIEN=$O(^BQICARE(OWNR,7,MIEN,10,PIEN)) Q:'PIEN D
.. NEW DA,IENS,NAME,VALUE
.. S DA(2)=OWNR,DA(1)=MIEN,DA=PIEN,IENS=$$IENS^DILF(.DA)
.. S NAME=$$GET1^DIQ(90505.08,IENS,.01,"E")
.. S PTYP=$$PTYP^BQIDCDF(SOURCE,NAME)
.. I PTYP="T" S VALUE=$$GET1^DIQ(90505.08,IENS,.03,"E")
.. I PTYP'="T" S VALUE=$$GET1^DIQ(90505.08,IENS,.02,"E")
.. I $E(VALUE,1,2)="T-" S VALUE=$$DATE^BQIUL1(VALUE)
.. I VALUE'="" S PARMS(NAME)=VALUE Q
.. I VALUE="" D
... Q:'$D(^BQICARE(OWNR,7,MIEN,10,PIEN,1))
... S PMIEN=0 F S PMIEN=$O(^BQICARE(OWNR,7,MIEN,10,PIEN,1,PMIEN)) Q:'PMIEN D
.... NEW DA,IENS,VALUE
.... S DA(3)=OWNR,DA(2)=MIEN,DA(1)=PIEN,DA=PMIEN,IENS=$$IENS^DILF(.DA)
.... I PTYP="T" S VALUE=$$GET1^DIQ(90505.81,IENS,.02,"E")
.... I PTYP'="T" S VALUE=$$GET1^DIQ(90505.81,IENS,.01,"E")
.... S MPARMS(NAME,VALUE)=""
. X EXEC
. S DFN=0 F S DFN=$O(@GLREF@(DFN)) Q:'DFN S @MDATA@(DFN)=""
S GLREF=$NA(^TMP(UID,"BQIPMYP"))
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
D STA^BQIPLRF(OWNR,PLIEN)
Q
;
FLT ; Get filter parameters
S PPIEN=$$PP^BQIDCDF(FSOURCE) I PPIEN=-1 S BMXSEC="Pre-defined filter type "_FSOURCE_" was not found" Q
S FEXEC=$$GET1^DIQ(90506,PPIEN_",",2,"E")
S N=0
F S N=$O(^BQICARE(OWNR,1,PLIEN,15,N)) Q:'N D
. NEW DA,IENS,NAME,VALUE
. S DA(2)=OWNR,DA(1)=PLIEN,DA=N,IENS=$$IENS^DILF(.DA)
. S NAME=$$GET1^DIQ(90505.115,IENS,.01,"E")
. S PTYP=$$PTYP^BQIDCDF(FSOURCE,NAME)
. I PTYP="T" S VALUE=$$GET1^DIQ(90505.115,IENS,.03,"E")
. I PTYP'="T" S VALUE=$$GET1^DIQ(90505.115,IENS,.02,"E")
. I $E(VALUE,1,2)="T-" S VALUE=$$DATE^BQIUL1(VALUE)
. I VALUE'="" S PARMS(NAME)=VALUE D CKAS Q
. I VALUE="" D
.. Q:'$D(^BQICARE(OWNR,1,PLIEN,15,N,1))
.. S NN=0 F S NN=$O(^BQICARE(OWNR,1,PLIEN,15,N,1,NN)) Q:'NN D
... NEW DA,IENS,VALUE
... S DA(3)=OWNR,DA(2)=PLIEN,DA(1)=N,DA=NN,IENS=$$IENS^DILF(.DA)
... I PTYP="T" S VALUE=$$GET1^DIQ(90505.1151,IENS,.02,"E")
... I PTYP'="T" S VALUE=$$GET1^DIQ(90505.1151,IENS,.01,"E")
... I $E(VALUE,1,2)="T-" S VALUE=$$DATE^BQIUL1(VALUE)
... S MPARMS(NAME,VALUE)="" I NAME="NUMVIS" S MAPARMS(NN,NAME)=VALUE
... S ASN=0
... F S ASN=$O(^BQICARE(OWNR,1,PLIEN,15,N,1,NN,2,ASN)) Q:'ASN D
.... NEW DA,IENS
.... S DA(4)=OWNR,DA(3)=PLIEN,DA(2)=N,DA(1)=NN,DA=ASN,IENS=$$IENS^DILF(.DA)
.... S ASSOC=$$GET1^DIQ(90505.11512,IENS,.01,"E")
.... S ATYP=$$PTYP^BQIDCDF(FSOURCE,ASSOC)
.... I ATYP="T" S AVALUE=$$GET1^DIQ(90505.11512,IENS,.03,"E")
.... I ATYP'="T" S AVALUE=$$GET1^DIQ(90505.11512,IENS,.02,"E")
.... I $E(AVALUE,1,2)="T-" S AVALUE=$$DATE^BQIUL1(AVALUE)
.... I AVALUE'="" D
..... I NAME'="NUMVIS" S APARMS(NAME,VALUE,ASSOC)=AVALUE Q
..... S APARMS(NAME,VALUE,ASSOC,AVALUE)="",MAPARMS(NN,ASSOC)=AVALUE,MAPARMS(NN,NAME)=VALUE
.... I AVALUE="" D
..... Q:'$D(^BQICARE(OWNR,1,PLIEN,15,N,1,NN,2,ASN,1))
..... S ANN=0 F S ANN=$O(^BQICARE(OWNR,1,PLIEN,15,N,1,NN,2,ASN,1,ANN)) Q:'ANN D
...... NEW DA,IENS
...... S DA(5)=OWNR,DA(4)=PLIEN,DA(3)=N,DA(2)=NN,DA(1)=ASN,DA=ANN,IENS=$$IENS^DILF(.DA)
...... I ATYP="T" S AVALUE=$$GET1^DIQ(90505.115121,IENS,.02,"E")
...... I ATYP'="T" S AVALUE=$$GET1^DIQ(90505.115121,IENS,.01,"E")
...... I $E(AVALUE,1,2)="T-" S AVALUE=$$DATE^BQIUL1(AVALUE)
...... S MAPARMS(NAME,VALUE,ASSOC,AVALUE)=""
; set FGLOB equal to the global that was populated by executable
S FGLOB=$G(GLREF)
; call filter code
X FEXEC
Q
;
CKAS ; Check for associated parameters
S ASN=0
F S ASN=$O(^BQICARE(OWNR,1,PLIEN,15,N,2,ASN)) Q:'ASN D
. NEW DA,IENS
. S DA(3)=OWNR,DA(2)=PLIEN,DA(1)=N,DA=ASN,IENS=$$IENS^DILF(.DA)
. S ASSOC=$$GET1^DIQ(90505.1152,IENS,.01,"E")
. S ATYP=$$PTYP^BQIDCDF(FSOURCE,ASSOC)
. I ATYP="T" S AVALUE=$$GET1^DIQ(90505.1152,IENS,.03,"E")
. I ATYP'="T" S AVALUE=$$GET1^DIQ(90505.1152,IENS,.02,"E")
. I $E(AVALUE,1,2)="T-" S AVALUE=$$DATE^BQIUL1(AVALUE)
. I AVALUE'="" D
.. I NAME'="NUMVIS" S APARMS(NAME,VALUE,ASSOC)=AVALUE Q
.. S APARMS(NAME,VALUE,ASSOC)=AVALUE,MAPARMS(N,ASSOC)=AVALUE,MAPARMS(N,NAME)=VALUE
. I AVALUE="" D
.. I NAME="NUMVIS" S MAPARMS(N,NAME)=VALUE
.. Q:'$D(^BQICARE(OWNR,1,PLIEN,15,N,2,ASN,1))
.. S ANN=0 F S ANN=$O(^BQICARE(OWNR,1,PLIEN,15,N,2,ASN,1,ANN)) Q:'ANN D
... NEW DA,IENS,AVALUE
... S DA(4)=OWNR,DA(3)=PLIEN,DA(2)=N,DA(1)=ASN,DA=ANN,IENS=$$IENS^DILF(.DA)
... I ATYP="T" S AVALUE=$$GET1^DIQ(90505.11521,IENS,.02,"E")
... I ATYP'="T" S AVALUE=$$GET1^DIQ(90505.11521,IENS,.01,"E")
... I $E(AVALUE,1,2)="T-" S AVALUE=$$DATE^BQIUL1(AVALUE)
... S MAPARMS(NAME,VALUE,ASSOC,AVALUE)=""
Q
BQIPLPP ;PRXM/HC/ALA-Populate a panel based on definition ; 19 Oct 2005 12:26 PM
+1 ;;2.4;ICARE MANAGEMENT SYSTEM;**2**;Apr 01, 2015;Build 10
+2 ;
+3 QUIT
+4 ;
POP(DATA,OWNR,PLIEN,KEEP,OVER) ;EP - BQI POPULATE PANEL
+1 ;
+2 ;Description
+3 ; Populate the patient list based on the panel definition
+4 ;Input
+5 ; OWNR - Owner of panel internal entry number
+6 ; PLIEN - Panel internal entry number
+7 ; KEEP - "N" if manual adds/removes should be 'removed' (any other value assumes "Y")
+8 ; OVER - User ien to replace DUZ (90505.01,3.5) if passed
+9 ;Output
+10 ; DATA = name of global (passed by reference) in which the data is stored
+11 ;
+12 ; NUMBER OF PATIENTS found if successful or BMXSEC if error.
+13 ; Final patient list should have been filed in node 40 of the panel.
+14 ;
+15 ; Check if share and has write access
+16 IF $GET(BQINIGHT)=""
IF '$$CKSHR^BQIPLSH(OWNR,PLIEN)
SET BMXSEC="You do not have write access"
QUIT
+17 ;
+18 NEW UID,II,TEMP
+19 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+20 SET DATA=$NAME(^TMP(UID,"BQIPLPP"))
SET TEMP=$NAME(^TMP(UID,"BQITEMP"))
+21 KILL @DATA,@TEMP
+22 ;
+23 SET II=0
+24 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPLPP D UNWIND^%ZTER"
+25 ;
+26 NEW DA,IENS,TYPE,SOURCE,FSOURCE,PPIEN,PTYP,N,NN,PARMS,MPARMS
+27 NEW EXEC,FEXEC,CNT,QMIEN,ANN,APARMS,MAPARMS
+28 SET KEEP=$GET(KEEP)
+29 SET DA(1)=OWNR
SET DA=PLIEN
SET IENS=$$IENS^DILF(.DA)
SET EXEC=""
+30 SET TYPE=$$GET1^DIQ(90505.01,IENS,.03,"I")
+31 SET SOURCE=$$GET1^DIQ(90505.01,IENS,.11,"E")
+32 SET FSOURCE=$$GET1^DIQ(90505.01,IENS,.14,"E")
+33 SET BQIUPD(90505.01,IENS,3.8)=$$NOW^XLFDT()
+34 ;
+35 ; Manual type has no requirements for populate.
IF TYPE="M"
GOTO DONE
+36 ;
+37 KILL PARMS,MPARMS
+38 ;
+39 ; Get parameters from panel definition
+40 SET N=0
FOR
SET N=$ORDER(^BQICARE(OWNR,1,PLIEN,10,N))
IF 'N
QUIT
Begin DoDot:1
+41 NEW DA,IENS,NAME,VALUE
+42 SET DA(2)=OWNR
SET DA(1)=PLIEN
SET DA=N
SET IENS=$$IENS^DILF(.DA)
+43 SET NAME=$$GET1^DIQ(90505.02,IENS,.01,"E")
+44 SET PTYP=$$PTYP^BQIDCDF(SOURCE,NAME)
+45 IF PTYP="T"
SET VALUE=$$GET1^DIQ(90505.02,IENS,.03,"E")
+46 IF PTYP'="T"
SET VALUE=$$GET1^DIQ(90505.02,IENS,.02,"E")
+47 IF $EXTRACT(VALUE,1,2)="T-"
SET VALUE=$$DATE^BQIUL1(VALUE)
+48 IF VALUE'=""
IF $ORDER(^BQICARE(OWNR,1,PLIEN,10,N,2,0))=""
SET PARMS(NAME)=VALUE
QUIT
+49 IF VALUE'=""
IF $ORDER(^BQICARE(OWNR,1,PLIEN,10,N,2,0))'=""
Begin DoDot:2
+50 NEW AN
+51 SET AN=0
SET PARMS(NAME)=VALUE
+52 FOR
SET AN=$ORDER(^BQICARE(OWNR,1,PLIEN,10,N,2,AN))
IF 'AN
QUIT
Begin DoDot:3
+53 NEW DA,IENS,ANAME,AVALUE,APTYP
+54 SET DA(3)=OWNR
SET DA(2)=PLIEN
SET DA(1)=N
SET DA=AN
SET IENS=$$IENS^DILF(.DA)
+55 SET ANAME=$$GET1^DIQ(90505.22,IENS,.01,"E")
+56 SET APTYP=$$PTYP^BQIDCDF(SOURCE,ANAME)
+57 IF APTYP="T"
SET AVALUE=$$GET1^DIQ(90505.22,IENS,.03,"E")
+58 IF APTYP'="T"
SET AVALUE=$$GET1^DIQ(90505.22,IENS,.02,"E")
+59 IF $EXTRACT(AVALUE,1,2)="T-"
SET AVALUE=$$DATE^BQIUL1(AVALUE)
+60 SET PARMS(NAME)=$GET(PARMS(NAME))_"^"_ANAME_"="_AVALUE_"^"
End DoDot:3
End DoDot:2
QUIT
+61 ; If no single value, check for multiple values
+62 IF VALUE=""
Begin DoDot:2
+63 IF '$DATA(^BQICARE(OWNR,1,PLIEN,10,N,1))
QUIT
+64 SET NN=0
FOR
SET NN=$ORDER(^BQICARE(OWNR,1,PLIEN,10,N,1,NN))
IF 'NN
QUIT
Begin DoDot:3
+65 NEW AN,DA,IENS,VALUE
+66 SET DA(3)=OWNR
SET DA(2)=PLIEN
SET DA(1)=N
SET DA=NN
SET IENS=$$IENS^DILF(.DA)
+67 IF PTYP="T"
SET VALUE=$$GET1^DIQ(90505.21,IENS,.02,"E")
+68 IF PTYP'="T"
SET VALUE=$$GET1^DIQ(90505.21,IENS,.01,"E")
+69 IF $ORDER(^BQICARE(OWNR,1,PLIEN,10,N,1,NN,2,0))=""
SET MPARMS(NAME,VALUE)=""
QUIT
+70 SET AN=0
+71 FOR
SET AN=$ORDER(^BQICARE(OWNR,1,PLIEN,10,N,1,NN,2,AN))
IF 'AN
QUIT
Begin DoDot:4
+72 NEW DA,IENS,ANAME,AVALUE,APTYP
+73 SET DA(4)=OWNR
SET DA(3)=PLIEN
SET DA(2)=N
SET DA(1)=NN
SET DA=AN
SET IENS=$$IENS^DILF(.DA)
+74 SET ANAME=$$GET1^DIQ(90505.212,IENS,.01,"E")
+75 SET APTYP=$$PTYP^BQIDCDF(SOURCE,ANAME)
+76 IF APTYP="T"
SET AVALUE=$$GET1^DIQ(90505.212,IENS,.03,"E")
+77 IF APTYP'="T"
SET AVALUE=$$GET1^DIQ(90505.212,IENS,.02,"E")
+78 IF $EXTRACT(AVALUE,1,2)="T-"
SET AVALUE=$$DATE^BQIUL1(AVALUE)
+79 SET MPARMS(NAME,VALUE)=$GET(MPARMS(NAME,VALUE))_ANAME_"="_AVALUE_"^"
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+80 ;
+81 IF TYPE="Y"
Begin DoDot:1
+82 ; Check if 'My Patients Definition' exists
+83 IF '$ORDER(^BQICARE(OWNR,7,0))
SET BMXSEC="MY PATIENTS DEFINITION was not found"
QUIT
+84 NEW DA,IENS
+85 SET DA(1)=OWNR
SET DA=PLIEN
SET IENS=$$IENS^DILF(.DA)
+86 KILL DESC
+87 DO DESC^BQIPDSCM(OWNR,PLIEN,.DESC)
+88 ;D PEN^BQIPLDSC(OWNR,PLIEN,.DESC)
+89 DO WP^DIE(90505.01,IENS,5,"","DESC")
+90 KILL DESC
+91 SET EXEC="D MYP^BQIPLPP"
End DoDot:1
IF $GET(BMXSEC)]""
GOTO EXIT
+92 ;
+93 IF TYPE="Q"
Begin DoDot:1
+94 NEW FLAG,MTEXT
+95 SET QMIEN=SOURCE
+96 IF '$DATA(^DIBT(QMIEN))
Begin DoDot:2
+97 SET BMXSEC="QMAN template was not found"
+98 SET FLAG=""
IF $GET(ZTSK)'=""
SET FLAG=1
+99 SET MTEXT(1,0)="The QMAN template used in panel "_$PIECE(^BQICARE(OWNR,1,PLIEN,0),U,1)_" appears"
+100 SET MTEXT(2,0)="to have been deleted from your server. You will be unable to manually or automatically populate this panel."
+101 DO ADD^BQINOTF("",OWNR,BMXSEC,.MTEXT,FLAG)
End DoDot:2
QUIT
+102 SET EXEC="D QM^BQIPLPP"
SET GLREF=$NAME(^TMP(UID,"BQIPQMAN"))
End DoDot:1
IF $GET(BMXSEC)'=""
GOTO EXIT
+103 ;
+104 IF TYPE="P"
Begin DoDot:1
+105 ; Find predefined panel and get parameters
+106 SET PPIEN=$$PP^BQIDCDF(SOURCE)
IF PPIEN=-1
SET BMXSEC="Pre-defined panel type "_SOURCE_" was not found"
QUIT
+107 SET EXEC=$$GET1^DIQ(90506,PPIEN_",",2,"E")
End DoDot:1
IF $GET(BMXSEC)'=""
GOTO EXIT
+108 ;
+109 SET FGLOB=""
+110 XECUTE EXEC
+111 ;
+112 KILL PARMS,MPARMS
+113 ;
+114 ; If filters exist
+115 IF $ORDER(^BQICARE(OWNR,1,PLIEN,15,0))'=""
DO FLT
IF $GET(BMXSEC)]""
GOTO EXIT
+116 ;
+117 ; save the data returned after executable and filter applied
+118 DO SAVE(OWNR,PLIEN,GLREF,KEEP,$GET(DCRIT))
+119 ;
DONE ;
+1 KILL DA
+2 SET DA(1)=OWNR
SET DA=PLIEN
SET IENS=$$IENS^DILF(.DA)
+3 ;
+4 SET BQIUPD(90505.01,IENS,.07)=$$NOW^XLFDT()
+5 SET BQIUPD(90505.01,IENS,3.5)=$SELECT($GET(OVER):OVER,1:DUZ)
+6 SET BQIUPD(90505.01,IENS,3.9)=$$NOW^XLFDT()
+7 DO FILE^DIE("","BQIUPD")
+8 ;
+9 SET CNT=$$GET1^DIQ(90505.01,IENS,.1,"E")
+10 IF CNT=""
SET CNT=0
+11 SET II=II+1
SET @DATA@(II)="I00010NUMBER_OF_PATIENTS"_$CHAR(30)
+12 SET II=II+1
SET @DATA@(II)=CNT_$CHAR(30)
+13 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+14 ;
EXIT ;
+1 KILL AGE,AUPNDAYS,AUPNDOB,AUPNDOD,AUPNPAT,AUPNSEX
+2 KILL DFN,DOB,SEX,SSN,X,Y,BQIUPD,GLREF,FGLOB
+3 QUIT
+4 ;
SAVE(OWNR,PLIEN,GLREF,KEEP,DCRIT) ;EP - Save patient list
+1 ;
+2 ; First delete any patient before saving
+3 SET DFN=0
+4 FOR
SET DFN=$ORDER(^BQICARE(OWNR,1,PLIEN,40,DFN))
IF 'DFN
QUIT
Begin DoDot:1
+5 NEW DA,IENS,STAT
+6 SET DA(2)=OWNR
SET DA(1)=PLIEN
SET DA=DFN
SET IENS=$$IENS^DILF(.DA)
+7 IF '$DATA(^DPT(DFN))
DO DPT^BQIPLCR(DFN)
QUIT
+8 ; if the patient was already 'added' or 'removed', quit unless KEEP is explicitly "N"
+9 SET STAT=$$GET1^DIQ(90505.04,IENS,.02,"I")
+10 IF STAT="A"!(STAT="R")
IF KEEP'="N"
QUIT
+11 ; save off original patients
+12 SET @TEMP@(DFN)=^BQICARE(OWNR,1,PLIEN,40,DFN,0)
+13 MERGE @TEMP@(DFN,5)=^BQICARE(OWNR,1,PLIEN,40,DFN,5)
+14 ; otherwise, delete patient from panel
+15 DO DPT^BQIPLCR(DFN)
End DoDot:1
+16 ;
+17 SET DFN=""
+18 FOR
SET DFN=$ORDER(@GLREF@(DFN))
IF DFN=""
QUIT
Begin DoDot:1
+19 IF '$DATA(^DPT(DFN))
QUIT
+20 ; if patient already in panel check for FLAG value
+21 IF $DATA(^BQICARE(OWNR,1,PLIEN,40,DFN))
Begin DoDot:2
+22 NEW DA,IENS,STAT
+23 SET DA(2)=OWNR
SET DA(1)=PLIEN
SET DA=DFN
SET IENS=$$IENS^DILF(.DA)
+24 ; if the patient was already 'added' or 'removed', quit to preserve that value
+25 SET STAT=$$GET1^DIQ(90505.04,IENS,.02,"I")
+26 IF STAT="A"!(STAT="R")
QUIT
End DoDot:2
QUIT
+27 ; otherwise, add patient to panel
+28 DO APT^BQIPLCR(DFN)
+29 IF $DATA(@TEMP@(DFN))
SET $PIECE(^BQICARE(OWNR,1,PLIEN,40,DFN,0),U,7)=$PIECE(@TEMP@(DFN),U,7)
End DoDot:1
+30 ;
+31 ; File any matched criteria
+32 IF $GET(DCRIT)'=""
Begin DoDot:1
+33 SET CTYP=""
+34 FOR
SET CTYP=$ORDER(@DCRIT@(CTYP))
IF CTYP=""
QUIT
Begin DoDot:2
+35 SET DFN=""
+36 FOR
SET DFN=$ORDER(@DCRIT@(CTYP,DFN))
IF DFN=""
QUIT
DO APMTC^BQIPLCR(.DCRIT,.CTYP,.DFN)
End DoDot:2
End DoDot:1
+37 ;
+38 ; Count the saved records
+39 DO CNTP^BQIPLCR(OWNR,PLIEN)
+40 KILL @TEMP
+41 QUIT
+42 ;
QM ; Find DFNs in a QMAN search template
+1 KILL @GLREF
+2 NEW DFN,FILE,IEN
+3 SET FILE=$PIECE($GET(^DIBT(QMIEN,0)),U,4)
+4 IF FILE=9000001
Begin DoDot:1
+5 SET DFN=0
+6 FOR
SET DFN=$ORDER(^DIBT(QMIEN,1,DFN))
IF 'DFN
QUIT
SET @GLREF@(DFN)=""
End DoDot:1
+7 IF FILE=9000010
Begin DoDot:1
+8 SET IEN=0
+9 FOR
SET IEN=$ORDER(^DIBT(QMIEN,1,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+10 IF $PIECE($GET(^AUPNVSIT(IEN,0)),U,11)=1
QUIT
+11 SET DFN=$PIECE($GET(^AUPNVSIT(IEN,0)),U,5)
IF DFN=""
QUIT
+12 SET @GLREF@(DFN)=""
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
MYP ; Find DFNs using the MY PATIENTS DEFINITION
+1 NEW MIEN,PIEN,PMIEN,DFN,MDATA
+2 SET MDATA=$NAME(^TMP(UID,"BQIPMYP"))
+3 KILL @MDATA
+4 SET MIEN=0
+5 FOR
SET MIEN=$ORDER(^BQICARE(OWNR,7,MIEN))
IF 'MIEN
QUIT
Begin DoDot:1
+6 NEW DA,IENS
+7 SET DA(1)=OWNR
SET DA=MIEN
SET IENS=$$IENS^DILF(.DA)
+8 SET SOURCE=$$GET1^DIQ(90505.07,IENS,.01,"E")
+9 SET PPIEN=$$PP^BQIDCDF(SOURCE)
IF PPIEN=-1
QUIT
+10 SET EXEC=$$GET1^DIQ(90506,PPIEN_",",2,"E")
+11 KILL PARMS,MPARMS
+12 SET PIEN=0
+13 FOR
SET PIEN=$ORDER(^BQICARE(OWNR,7,MIEN,10,PIEN))
IF 'PIEN
QUIT
Begin DoDot:2
+14 NEW DA,IENS,NAME,VALUE
+15 SET DA(2)=OWNR
SET DA(1)=MIEN
SET DA=PIEN
SET IENS=$$IENS^DILF(.DA)
+16 SET NAME=$$GET1^DIQ(90505.08,IENS,.01,"E")
+17 SET PTYP=$$PTYP^BQIDCDF(SOURCE,NAME)
+18 IF PTYP="T"
SET VALUE=$$GET1^DIQ(90505.08,IENS,.03,"E")
+19 IF PTYP'="T"
SET VALUE=$$GET1^DIQ(90505.08,IENS,.02,"E")
+20 IF $EXTRACT(VALUE,1,2)="T-"
SET VALUE=$$DATE^BQIUL1(VALUE)
+21 IF VALUE'=""
SET PARMS(NAME)=VALUE
QUIT
+22 IF VALUE=""
Begin DoDot:3
+23 IF '$DATA(^BQICARE(OWNR,7,MIEN,10,PIEN,1))
QUIT
+24 SET PMIEN=0
FOR
SET PMIEN=$ORDER(^BQICARE(OWNR,7,MIEN,10,PIEN,1,PMIEN))
IF 'PMIEN
QUIT
Begin DoDot:4
+25 NEW DA,IENS,VALUE
+26 SET DA(3)=OWNR
SET DA(2)=MIEN
SET DA(1)=PIEN
SET DA=PMIEN
SET IENS=$$IENS^DILF(.DA)
+27 IF PTYP="T"
SET VALUE=$$GET1^DIQ(90505.81,IENS,.02,"E")
+28 IF PTYP'="T"
SET VALUE=$$GET1^DIQ(90505.81,IENS,.01,"E")
+29 SET MPARMS(NAME,VALUE)=""
End DoDot:4
End DoDot:3
End DoDot:2
+30 XECUTE EXEC
+31 SET DFN=0
FOR
SET DFN=$ORDER(@GLREF@(DFN))
IF 'DFN
QUIT
SET @MDATA@(DFN)=""
End DoDot:1
+32 SET GLREF=$NAME(^TMP(UID,"BQIPMYP"))
+33 QUIT
+34 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(II)
IF $DATA(DATA)
SET II=II+1
SET @DATA@(II)=$CHAR(31)
+6 DO STA^BQIPLRF(OWNR,PLIEN)
+7 QUIT
+8 ;
FLT ; Get filter parameters
+1 SET PPIEN=$$PP^BQIDCDF(FSOURCE)
IF PPIEN=-1
SET BMXSEC="Pre-defined filter type "_FSOURCE_" was not found"
QUIT
+2 SET FEXEC=$$GET1^DIQ(90506,PPIEN_",",2,"E")
+3 SET N=0
+4 FOR
SET N=$ORDER(^BQICARE(OWNR,1,PLIEN,15,N))
IF 'N
QUIT
Begin DoDot:1
+5 NEW DA,IENS,NAME,VALUE
+6 SET DA(2)=OWNR
SET DA(1)=PLIEN
SET DA=N
SET IENS=$$IENS^DILF(.DA)
+7 SET NAME=$$GET1^DIQ(90505.115,IENS,.01,"E")
+8 SET PTYP=$$PTYP^BQIDCDF(FSOURCE,NAME)
+9 IF PTYP="T"
SET VALUE=$$GET1^DIQ(90505.115,IENS,.03,"E")
+10 IF PTYP'="T"
SET VALUE=$$GET1^DIQ(90505.115,IENS,.02,"E")
+11 IF $EXTRACT(VALUE,1,2)="T-"
SET VALUE=$$DATE^BQIUL1(VALUE)
+12 IF VALUE'=""
SET PARMS(NAME)=VALUE
DO CKAS
QUIT
+13 IF VALUE=""
Begin DoDot:2
+14 IF '$DATA(^BQICARE(OWNR,1,PLIEN,15,N,1))
QUIT
+15 SET NN=0
FOR
SET NN=$ORDER(^BQICARE(OWNR,1,PLIEN,15,N,1,NN))
IF 'NN
QUIT
Begin DoDot:3
+16 NEW DA,IENS,VALUE
+17 SET DA(3)=OWNR
SET DA(2)=PLIEN
SET DA(1)=N
SET DA=NN
SET IENS=$$IENS^DILF(.DA)
+18 IF PTYP="T"
SET VALUE=$$GET1^DIQ(90505.1151,IENS,.02,"E")
+19 IF PTYP'="T"
SET VALUE=$$GET1^DIQ(90505.1151,IENS,.01,"E")
+20 IF $EXTRACT(VALUE,1,2)="T-"
SET VALUE=$$DATE^BQIUL1(VALUE)
+21 SET MPARMS(NAME,VALUE)=""
IF NAME="NUMVIS"
SET MAPARMS(NN,NAME)=VALUE
+22 SET ASN=0
+23 FOR
SET ASN=$ORDER(^BQICARE(OWNR,1,PLIEN,15,N,1,NN,2,ASN))
IF 'ASN
QUIT
Begin DoDot:4
+24 NEW DA,IENS
+25 SET DA(4)=OWNR
SET DA(3)=PLIEN
SET DA(2)=N
SET DA(1)=NN
SET DA=ASN
SET IENS=$$IENS^DILF(.DA)
+26 SET ASSOC=$$GET1^DIQ(90505.11512,IENS,.01,"E")
+27 SET ATYP=$$PTYP^BQIDCDF(FSOURCE,ASSOC)
+28 IF ATYP="T"
SET AVALUE=$$GET1^DIQ(90505.11512,IENS,.03,"E")
+29 IF ATYP'="T"
SET AVALUE=$$GET1^DIQ(90505.11512,IENS,.02,"E")
+30 IF $EXTRACT(AVALUE,1,2)="T-"
SET AVALUE=$$DATE^BQIUL1(AVALUE)
+31 IF AVALUE'=""
Begin DoDot:5
+32 IF NAME'="NUMVIS"
SET APARMS(NAME,VALUE,ASSOC)=AVALUE
QUIT
+33 SET APARMS(NAME,VALUE,ASSOC,AVALUE)=""
SET MAPARMS(NN,ASSOC)=AVALUE
SET MAPARMS(NN,NAME)=VALUE
End DoDot:5
+34 IF AVALUE=""
Begin DoDot:5
+35 IF '$DATA(^BQICARE(OWNR,1,PLIEN,15,N,1,NN,2,ASN,1))
QUIT
+36 SET ANN=0
FOR
SET ANN=$ORDER(^BQICARE(OWNR,1,PLIEN,15,N,1,NN,2,ASN,1,ANN))
IF 'ANN
QUIT
Begin DoDot:6
+37 NEW DA,IENS
+38 SET DA(5)=OWNR
SET DA(4)=PLIEN
SET DA(3)=N
SET DA(2)=NN
SET DA(1)=ASN
SET DA=ANN
SET IENS=$$IENS^DILF(.DA)
+39 IF ATYP="T"
SET AVALUE=$$GET1^DIQ(90505.115121,IENS,.02,"E")
+40 IF ATYP'="T"
SET AVALUE=$$GET1^DIQ(90505.115121,IENS,.01,"E")
+41 IF $EXTRACT(AVALUE,1,2)="T-"
SET AVALUE=$$DATE^BQIUL1(AVALUE)
+42 SET MAPARMS(NAME,VALUE,ASSOC,AVALUE)=""
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+43 ; set FGLOB equal to the global that was populated by executable
+44 SET FGLOB=$GET(GLREF)
+45 ; call filter code
+46 XECUTE FEXEC
+47 QUIT
+48 ;
CKAS ; Check for associated parameters
+1 SET ASN=0
+2 FOR
SET ASN=$ORDER(^BQICARE(OWNR,1,PLIEN,15,N,2,ASN))
IF 'ASN
QUIT
Begin DoDot:1
+3 NEW DA,IENS
+4 SET DA(3)=OWNR
SET DA(2)=PLIEN
SET DA(1)=N
SET DA=ASN
SET IENS=$$IENS^DILF(.DA)
+5 SET ASSOC=$$GET1^DIQ(90505.1152,IENS,.01,"E")
+6 SET ATYP=$$PTYP^BQIDCDF(FSOURCE,ASSOC)
+7 IF ATYP="T"
SET AVALUE=$$GET1^DIQ(90505.1152,IENS,.03,"E")
+8 IF ATYP'="T"
SET AVALUE=$$GET1^DIQ(90505.1152,IENS,.02,"E")
+9 IF $EXTRACT(AVALUE,1,2)="T-"
SET AVALUE=$$DATE^BQIUL1(AVALUE)
+10 IF AVALUE'=""
Begin DoDot:2
+11 IF NAME'="NUMVIS"
SET APARMS(NAME,VALUE,ASSOC)=AVALUE
QUIT
+12 SET APARMS(NAME,VALUE,ASSOC)=AVALUE
SET MAPARMS(N,ASSOC)=AVALUE
SET MAPARMS(N,NAME)=VALUE
End DoDot:2
+13 IF AVALUE=""
Begin DoDot:2
+14 IF NAME="NUMVIS"
SET MAPARMS(N,NAME)=VALUE
+15 IF '$DATA(^BQICARE(OWNR,1,PLIEN,15,N,2,ASN,1))
QUIT
+16 SET ANN=0
FOR
SET ANN=$ORDER(^BQICARE(OWNR,1,PLIEN,15,N,2,ASN,1,ANN))
IF 'ANN
QUIT
Begin DoDot:3
+17 NEW DA,IENS,AVALUE
+18 SET DA(4)=OWNR
SET DA(3)=PLIEN
SET DA(2)=N
SET DA(1)=ASN
SET DA=ANN
SET IENS=$$IENS^DILF(.DA)
+19 IF ATYP="T"
SET AVALUE=$$GET1^DIQ(90505.11521,IENS,.02,"E")
+20 IF ATYP'="T"
SET AVALUE=$$GET1^DIQ(90505.11521,IENS,.01,"E")
+21 IF $EXTRACT(AVALUE,1,2)="T-"
SET AVALUE=$$DATE^BQIUL1(AVALUE)
+22 SET MAPARMS(NAME,VALUE,ASSOC,AVALUE)=""
End DoDot:3
End DoDot:2
End DoDot:1
+23 QUIT
