BQIPLDS1 ;PRXM/HC/ALA-Panel Description Utility (cont) ; 7 Apr 2008 4:28 PM
;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66
;
Q
;
FILTER(OWNR,PLIEN) ;EP - Include filter description
;
; Retrieve all filters for this panel and return as a string in filter order
; as defined in the ICARE DEFINITIONS file (90506.03,.1)
;
N DA,FIENS,FSOURCE,FIEN,FN,FPARMS,FMPARMS,FILTER
N AFILTER,AP,AFPARMS,AFMPARMS,MAP
S DA(1)=OWNR,DA=PLIEN,FIENS=$$IENS^DILF(.DA)
S FSOURCE=$$GET1^DIQ(90505.01,FIENS,.14,"E")
; if there is no filter source, the filter may have been turned off
I FSOURCE="" Q ""
S FIEN=$$PP^BQIDCDF(FSOURCE) ; Filter ien
I FIEN=-1 S BMXSEC="Filter SOURCE was not found" Q ""
; Get filters from panel definition
S FN=0 F S FN=$O(^BQICARE(OWNR,1,PLIEN,15,FN)) Q:'FN D
. NEW DA,IENS,FNAME,VALUE,BQFIL
. S DA(2)=OWNR,DA(1)=PLIEN,DA=FN,IENS=$$IENS^DILF(.DA)
. S FNAME=$$GET1^DIQ(90505.115,IENS,.01,"E") Q:FNAME="" S FILTER(FNAME)=""
. S PTYP=$$PTYP^BQIDCDF(FSOURCE,FNAME)
. S VALUE=$$GVAL(PTYP,90505.115,IENS,FSOURCE,FNAME)
. I VALUE'="" D Q
.. S FPARMS(FNAME)=VALUE
.. ; Retrieve associated parameters
.. ; Single associated parameter
.. S AP=0
.. F S AP=$O(^BQICARE(OWNR,1,PLIEN,15,FN,2,AP)) Q:'AP D
... NEW DA,IENS,APNAME,AVALUE,APTYP
... S DA(3)=OWNR,DA(2)=PLIEN,DA(1)=FN,DA=AP,IENS=$$IENS^DILF(.DA)
... S APNAME=$$GET1^DIQ(90505.1152,IENS,.01,"E") Q:APNAME="" S AFILTER(FNAME,APNAME)=""
... S APTYP=$$PTYP^BQIDCDF(FSOURCE,APNAME)
... S AVALUE=$$GVAL(APTYP,90505.1152,IENS,FSOURCE,APNAME)
... I $T(@(APNAME))'="" D @APNAME
... I AVALUE'="" S AFPARMS(FNAME,VALUE,APNAME)=AVALUE
... I AVALUE="" D
.... Q:'$D(^BQICARE(OWNR,1,PLIEN,15,FN,2,AP,1))
.... ; Multiple associated parameter
.... S MAP=0
.... F S MAP=$O(^BQICARE(OWNR,1,PLIEN,15,FN,2,AP,1,MAP)) Q:'MAP D
..... NEW DA,IENS
..... S DA(4)=OWNR,DA(3)=PLIEN,DA(2)=FN,DA(1)=AP,DA=MAP,IENS=$$IENS^DILF(.DA)
..... S AVALUE=$$GET1^DIQ(90505.11521,IENS,.01,"E")
..... I $T(@(APNAME))'="" D @APNAME
..... I AVALUE'="" S AFPARMS(FNAME,VALUE,APNAME,AVALUE)=""
. I VALUE="" D
.. Q:'$D(^BQICARE(OWNR,1,PLIEN,15,FN,1))
.. NEW MN
.. S MN=0 F S MN=$O(^BQICARE(OWNR,1,PLIEN,15,FN,1,MN)) Q:'MN D
... NEW DA,IENS,VALUE,BQFIL
... S DA(3)=OWNR,DA(2)=PLIEN,DA(1)=FN,DA=MN,IENS=$$IENS^DILF(.DA)
... S VALUE=$$GMVAL(PTYP,90505.1151,IENS,FSOURCE,FNAME)
... I VALUE'="" S FMPARMS(FNAME,VALUE)=""
... ; Retrieve associated parameters
... ; Single associated parameter
... S AP=0
... F S AP=$O(^BQICARE(OWNR,1,PLIEN,15,FN,1,MN,2,AP)) Q:'AP D
.... NEW DA,IENS,APNAME,AVALUE,APTYP
.... S DA(4)=OWNR,DA(3)=PLIEN,DA(2)=FN,DA(1)=MN,DA=AP,IENS=$$IENS^DILF(.DA)
.... S APNAME=$$GET1^DIQ(90505.11512,IENS,.01,"E") Q:APNAME="" S AFILTER(FNAME,APNAME)=""
.... S APTYP=$$PTYP^BQIDCDF(FSOURCE,APNAME)
.... S AVALUE=$$GVAL(APTYP,90505.11512,IENS,FSOURCE,APNAME)
.... I $T(@(APNAME))'="" D @APNAME
.... I AVALUE'="" S AFMPARMS(FNAME,VALUE,APNAME,AVALUE)=""
.... I AVALUE="" D
..... Q:'$D(^BQICARE(OWNR,1,PLIEN,15,FN,1,MN,2,AP,1))
..... ; Multiple associated parameter
..... S MAP=0
..... F S MAP=$O(^BQICARE(OWNR,1,PLIEN,15,FN,1,MN,2,AP,1,MAP)) Q:'MAP D
...... NEW DA,IENS
...... S DA(5)=OWNR,DA(4)=PLIEN,DA(3)=FN,DA(2)=MN,DA(1)=AP,DA=MAP,IENS=$$IENS^DILF(.DA)
...... S AVALUE=$$GET1^DIQ(90505.115121,IENS,.01,"E")
...... I $T(@(APNAME))'="" D @APNAME
...... I AVALUE'="" S AFMPARMS(FNAME,VALUE,APNAME,AVALUE)=""
; Load description and executable code
N X,DIC,Y,FX,FDES,FORD,FDESC,DA,IENS
S FNAME="",FDESC=""
F S FNAME=$O(FILTER(FNAME)) Q:FNAME="" D
. S X=FNAME,DIC(0)="NZ",DIC="^BQI(90506,"_FIEN_",3," D ^DIC
. Q:Y<0 S DA=$P(Y,"^"),DA(1)=FIEN,IENS=$$IENS^DILF(.DA)
. S FX=$$GET1^DIQ(90506.03,IENS,2,"I")
. I FX'="" X FX
. S FDES=$$GET1^DIQ(90506.03,IENS,4,"I")
. S FORD=$$GET1^DIQ(90506.03,IENS,.1,"I")
. Q:FORD=""
. I FDES'="" S FDES(FORD)=FDES
S FORD="" F S FORD=$O(FDES(FORD)) Q:FORD="" S FDESC=FDESC_FDES(FORD)_"; "
;S FDESC=$E(FDESC,1,$L(FDESC)-2) ; Remove trailing "; "
S FDESC=$$TKO^BQIUL1(FDESC,"; ")
I $D(AFPARMS) D
. N CAT,AVAL,TP,VALS,FDSC
. S CAT=""
. F S CAT=$O(FPARMS(CAT)) Q:CAT="" I FPARMS(CAT)'="",$D(AFPARMS(CAT,FPARMS(CAT))) D
.. S TP=""
.. F S TP=$O(AFPARMS(CAT,FPARMS(CAT),TP)) Q:TP="" D
... S AVAL="",VALS=$$GDSC(TP,FIEN)
... F S AVAL=$O(AFPARMS(CAT,FPARMS(CAT),TP,AVAL)) Q:AVAL="" D
.... S VALS=VALS_AVAL_", "
... S VALS=$$TKO^BQIUL1(VALS,", ")
.. I VALS'="" S FPARMS(CAT)=FPARMS(CAT)_" ("_VALS_")"
I $D(FMPARMS) D
. S FNAME=""
. F S FNAME=$O(FMPARMS(FNAME)) Q:FNAME="" D
.. S VAL="",VALS=""
.. F S VAL=$O(FMPARMS(FNAME,VAL)) Q:VAL="" D
... S VALS=VALS_VAL_$$ADDAP(FNAME,VAL)_", "
.. S VALS=$$TKO^BQIUL1(VALS,", ")
.. S FPARMS(FNAME)=VALS
I FDESC["|" D
. F S FDESC=$P(FDESC,"|",1)_$G(FPARMS($P(FDESC,"|",2)))_$P(FDESC,"|",3,99) Q:FDESC'["|"
I FDESC'="" S FDESC=$$TKO^BQIUL1(FDESC,", ")
Q FDESC
;
GVAL(PTYP,FILN,IENS,SRC,NM) ; EP - Get value of parameter/filter
N VALUE,BQFIL
I PTYP="T" D
. S VALUE=$$GET1^DIQ(FILN,IENS,.03,"E")
. S BQFIL=$$FILN^BQIDCDF(SRC,NM) Q:BQFIL=""
. S VALUE=$$GET1^DIQ(BQFIL,VALUE,.01,"E")
I PTYP'="T" S VALUE=$$GET1^DIQ(FILN,IENS,.02,"E")
I PTYP="D" S VALUE=$$UP^XLFSTR($$FMTE^XLFDT(VALUE,1))
I PTYP="R" D
. S VALUE=$$DATE^BQIUL1(VALUE)
. S VALUE=$$UP^XLFSTR($$FMTE^XLFDT(VALUE,1))
Q VALUE
;
GMVAL(PTYP,FILN,IENS,SRC,NM) ; EP - Get value for multiples
N VALUE,BQFIL
I PTYP="T" D
. S VALUE=$$GET1^DIQ(FILN,IENS,.02,"E")
. S BQFIL=$$FILN^BQIDCDF(SRC,NM) Q:BQFIL=""
. S VALUE=$$GET1^DIQ(BQFIL,VALUE,.01,"E")
I PTYP'="T" S VALUE=$$GET1^DIQ(FILN,IENS,.01,"E")
Q VALUE
;
GDSC(CAT,FIEN) ; EP - Get filter description
N X,DIC,Y,DA,IENS
S X=CAT,DIC(0)="NZ",DIC="^BQI(90506,"_FIEN_",3," D ^DIC
I Y<0 Q ""
S DA=$P(Y,"^"),DA(1)=FIEN,IENS=$$IENS^DILF(.DA)
S FDSC=$$GET1^DIQ(90506.03,IENS,.09,"I")
I FDSC'="" S FDSC=FDSC_" "
Q FDSC
;
ADDAP(FNM,VALUE) ; EP - Return associated parameters text for multiple filter
N TP,AVAL,VALS
S (TP,VALS)=""
F S TP=$O(AFMPARMS(FNM,VALUE,TP)) Q:TP="" D
. S VALS=VALS_" ("_$$GDSC(TP,FIEN),AVAL="" D
.. F S AVAL=$O(AFMPARMS(FNM,VALUE,TP,AVAL)) Q:AVAL="" D
... S VALS=VALS_AVAL_", "
.. S VALS=$$TKO^BQIUL1(VALS,", ")_")"
Q VALS
;
DXSTAT ; EP - Translate code to description for dx tag statuses
S AVALUE=$S(AVALUE="A":"Accepted",AVALUE="P":"Proposed",AVALUE="N":"Not Accepted",AVALUE="V":"No Longer Valid",AVALUE="S":"Superseded",1:"")
Q
;
MYPT(OWNR,MPIEN,ICDEF,PARMS,MPARMS) ;EP - Set up My Patients - System Generated Description
;
;Description: This tag gets called by DESCRIPTION EXECUTABLE code in 90506. The process is
; started from PEN^BQIPLDSC. It sets up the single field PARMS array and the
; multiple field MPARMS array with information found in the file 90505, node 7.
;
;Parameters:
; OWNR = Owner
; MPIEN = File 90505, Node 7 IEN
; ICDEF = ICARE DEFINITIONS Name
; PARMS = Array of Fields and Values (Updated By This Tag)
; MPARMS = Array of Multiple Fields and Values (Updated By This Tag)
;
NEW DA,IENS,N,SOURCE
S SOURCE="PATIENTS ASSIGNED TO" ;Use the field defs from PATIENTS ASSIGNED TO since they are the same
S N=0 F S N=$O(^BQICARE(OWNR,7,MPIEN,10,N)) Q:'N D
. NEW DA,IENS,NAME,DESCEX,VALUE,PPIEN,PTYP,BQFIL
. S DA(2)=OWNR,DA(1)=MPIEN,DA=N,IENS=$$IENS^DILF(.DA)
. S NAME=$$GET1^DIQ(90505.08,IENS,.01,"E")
. ;
. S PPIEN=$$PP^BQIDCDF(SOURCE)
. I PPIEN S DESCEX=$$GET1^DIQ(90506,PPIEN,5,"I")
. S PTYP=$$PTYP^BQIDCDF(SOURCE,NAME)
. I PTYP="T" D
.. S VALUE=$$GET1^DIQ(90505.08,IENS,.03,"E")
.. S BQFIL=$$FILN^BQIDCDF(SOURCE,NAME) Q:BQFIL=""
.. S VALUE=$$GET1^DIQ(BQFIL,VALUE,.01,"E")
. I PTYP'="T" S VALUE=$$GET1^DIQ(90505.08,IENS,.02,"E")
. ;
. ;Save Provider
. I NAME="PROV" D Q
.. I '$D(PARMS("PROV")) S PARMS("PROV")=VALUE
. ;
. ;Save Single-Stored Specialty
. I NAME="SPEC",VALUE'="",$G(DESCEX)'="" X DESCEX
. ;
. ;Handle Multiple Fields
. I VALUE="",$D(^BQICARE(OWNR,7,MPIEN,10,N,1)) D Q
.. ;
.. NEW MN
.. S MN=0 F S MN=$O(^BQICARE(OWNR,7,MPIEN,10,N,1,MN)) Q:'MN D
... NEW DA,IENS,VALUE
... S DA(3)=OWNR,DA(2)=MPIEN,DA(1)=N,DA=MN,IENS=$$IENS^DILF(.DA)
... I PTYP="T" D
.... S VALUE=$$GET1^DIQ(90505.81,IENS,.02,"E")
.... S BQFIL=$$FILN^BQIDCDF(SOURCE,NAME) Q:BQFIL=""
.... S VALUE=$$GET1^DIQ(BQFIL,VALUE,.01,"E")
... I PTYP'="T" S VALUE=$$GET1^DIQ(90505.81,IENS,.01,"E")
... I VALUE'="",$G(DESCEX)'="" X DESCEX
... S MPARMS(NAME,VALUE)=""
. ;
. ;Save Single fields
. S PARMS(NAME)=VALUE
;
I $D(PARMS("VISITS")),$D(PARMS("TMFRAME")) D
. I ICDEF="MY PATIENTS-PRIMARY" D PSVST("PRIM",$G(PARMS("VISITS")),$G(PARMS("TMFRAME")),.MPARMS)
. I ICDEF="MY PATIENTS-PRIMARY/SECONDARY" D PSVST("PRSC",$G(PARMS("VISITS")),$G(PARMS("TMFRAME")),.MPARMS)
. K PARMS("VISITS"),PARMS("TMFRAME")
Q
;
SPEC ;EP - Format Specialty provider
I NAME'="SPEC" Q
I VALUE="" Q
N SPECNM
S SPECNM=$$GET1^DIQ(90360.3,VALUE,.01,"I")
I SPECNM="" Q
;
;Save each Specialty name in the "TYPE" node so it gets included in the
;generated description. The "SPEC" entry also needs removed so it doesn't show
;up as well.
K:$D(MPARMS("TYPE","SPEC")) MPARMS("TYPE","SPEC")
S MPARMS("TYPE",SPECNM)=""
Q
;
PSVST(BQITYPE,BQIVST,BQITIME,BQIMPRM) ;EP - Assemble Primary/Secondary Provider Visit Checks
;
;Description: This tag receives primary or secondary visit check information and moves it into
; the multiple field "TYPE" node so it will be included with the other specialties.
;
;Parameters:
;BQITYPE = "PRIM" - Primary or "PRSC" - Primary/Secondary
;BQIVST = # of visits parameter
;BQITIME = Date Range
;BQIMPRM = Passed in MPARMS array. Gets updated with visit check description
;
;
N STR
I BQITYPE=""!(BQIVST="")!(BQITIME="") Q
;
;Remove Existing Entry
K BQIMPRM("TYPE",BQITYPE)
;
;Assemble Visit Check Description
S STR=$S(BQITYPE="PRIM":"PRIMARY VISIT PROVIDER",1:"PRIMARY/SECONDARY VISIT PROVIDER")
S STR=STR_" "_BQIVST_$S(BQIVST>1:" VISITS",1:" VISIT")
S STR=STR_" IN "_$S(BQITIME="T-24M":"2 YRS",BQITIME="T-12M":"1 YR",1:$P(BQITIME,"T-",2))
;
;Save New Entry With Visit Check Description
S BQIMPRM("TYPE",STR)=""
Q
BQIPLDS1 ;PRXM/HC/ALA-Panel Description Utility (cont) ; 7 Apr 2008 4:28 PM
+1 ;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66
+2 ;
+3 QUIT
+4 ;
FILTER(OWNR,PLIEN) ;EP - Include filter description
+1 ;
+2 ; Retrieve all filters for this panel and return as a string in filter order
+3 ; as defined in the ICARE DEFINITIONS file (90506.03,.1)
+4 ;
+5 NEW DA,FIENS,FSOURCE,FIEN,FN,FPARMS,FMPARMS,FILTER
+6 NEW AFILTER,AP,AFPARMS,AFMPARMS,MAP
+7 SET DA(1)=OWNR
SET DA=PLIEN
SET FIENS=$$IENS^DILF(.DA)
+8 SET FSOURCE=$$GET1^DIQ(90505.01,FIENS,.14,"E")
+9 ; if there is no filter source, the filter may have been turned off
+10 IF FSOURCE=""
QUIT ""
+11 ; Filter ien
SET FIEN=$$PP^BQIDCDF(FSOURCE)
+12 IF FIEN=-1
SET BMXSEC="Filter SOURCE was not found"
QUIT ""
+13 ; Get filters from panel definition
+14 SET FN=0
FOR
SET FN=$ORDER(^BQICARE(OWNR,1,PLIEN,15,FN))
IF 'FN
QUIT
Begin DoDot:1
+15 NEW DA,IENS,FNAME,VALUE,BQFIL
+16 SET DA(2)=OWNR
SET DA(1)=PLIEN
SET DA=FN
SET IENS=$$IENS^DILF(.DA)
+17 SET FNAME=$$GET1^DIQ(90505.115,IENS,.01,"E")
IF FNAME=""
QUIT
SET FILTER(FNAME)=""
+18 SET PTYP=$$PTYP^BQIDCDF(FSOURCE,FNAME)
+19 SET VALUE=$$GVAL(PTYP,90505.115,IENS,FSOURCE,FNAME)
+20 IF VALUE'=""
Begin DoDot:2
+21 SET FPARMS(FNAME)=VALUE
+22 ; Retrieve associated parameters
+23 ; Single associated parameter
+24 SET AP=0
+25 FOR
SET AP=$ORDER(^BQICARE(OWNR,1,PLIEN,15,FN,2,AP))
IF 'AP
QUIT
Begin DoDot:3
+26 NEW DA,IENS,APNAME,AVALUE,APTYP
+27 SET DA(3)=OWNR
SET DA(2)=PLIEN
SET DA(1)=FN
SET DA=AP
SET IENS=$$IENS^DILF(.DA)
+28 SET APNAME=$$GET1^DIQ(90505.1152,IENS,.01,"E")
IF APNAME=""
QUIT
SET AFILTER(FNAME,APNAME)=""
+29 SET APTYP=$$PTYP^BQIDCDF(FSOURCE,APNAME)
+30 SET AVALUE=$$GVAL(APTYP,90505.1152,IENS,FSOURCE,APNAME)
+31 IF $TEXT(@(APNAME))'=""
DO @APNAME
+32 IF AVALUE'=""
SET AFPARMS(FNAME,VALUE,APNAME)=AVALUE
+33 IF AVALUE=""
Begin DoDot:4
+34 IF '$DATA(^BQICARE(OWNR,1,PLIEN,15,FN,2,AP,1))
QUIT
+35 ; Multiple associated parameter
+36 SET MAP=0
+37 FOR
SET MAP=$ORDER(^BQICARE(OWNR,1,PLIEN,15,FN,2,AP,1,MAP))
IF 'MAP
QUIT
Begin DoDot:5
+38 NEW DA,IENS
+39 SET DA(4)=OWNR
SET DA(3)=PLIEN
SET DA(2)=FN
SET DA(1)=AP
SET DA=MAP
SET IENS=$$IENS^DILF(.DA)
+40 SET AVALUE=$$GET1^DIQ(90505.11521,IENS,.01,"E")
+41 IF $TEXT(@(APNAME))'=""
DO @APNAME
+42 IF AVALUE'=""
SET AFPARMS(FNAME,VALUE,APNAME,AVALUE)=""
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
QUIT
+43 IF VALUE=""
Begin DoDot:2
+44 IF '$DATA(^BQICARE(OWNR,1,PLIEN,15,FN,1))
QUIT
+45 NEW MN
+46 SET MN=0
FOR
SET MN=$ORDER(^BQICARE(OWNR,1,PLIEN,15,FN,1,MN))
IF 'MN
QUIT
Begin DoDot:3
+47 NEW DA,IENS,VALUE,BQFIL
+48 SET DA(3)=OWNR
SET DA(2)=PLIEN
SET DA(1)=FN
SET DA=MN
SET IENS=$$IENS^DILF(.DA)
+49 SET VALUE=$$GMVAL(PTYP,90505.1151,IENS,FSOURCE,FNAME)
+50 IF VALUE'=""
SET FMPARMS(FNAME,VALUE)=""
+51 ; Retrieve associated parameters
+52 ; Single associated parameter
+53 SET AP=0
+54 FOR
SET AP=$ORDER(^BQICARE(OWNR,1,PLIEN,15,FN,1,MN,2,AP))
IF 'AP
QUIT
Begin DoDot:4
+55 NEW DA,IENS,APNAME,AVALUE,APTYP
+56 SET DA(4)=OWNR
SET DA(3)=PLIEN
SET DA(2)=FN
SET DA(1)=MN
SET DA=AP
SET IENS=$$IENS^DILF(.DA)
+57 SET APNAME=$$GET1^DIQ(90505.11512,IENS,.01,"E")
IF APNAME=""
QUIT
SET AFILTER(FNAME,APNAME)=""
+58 SET APTYP=$$PTYP^BQIDCDF(FSOURCE,APNAME)
+59 SET AVALUE=$$GVAL(APTYP,90505.11512,IENS,FSOURCE,APNAME)
+60 IF $TEXT(@(APNAME))'=""
DO @APNAME
+61 IF AVALUE'=""
SET AFMPARMS(FNAME,VALUE,APNAME,AVALUE)=""
+62 IF AVALUE=""
Begin DoDot:5
+63 IF '$DATA(^BQICARE(OWNR,1,PLIEN,15,FN,1,MN,2,AP,1))
QUIT
+64 ; Multiple associated parameter
+65 SET MAP=0
+66 FOR
SET MAP=$ORDER(^BQICARE(OWNR,1,PLIEN,15,FN,1,MN,2,AP,1,MAP))
IF 'MAP
QUIT
Begin DoDot:6
+67 NEW DA,IENS
+68 SET DA(5)=OWNR
SET DA(4)=PLIEN
SET DA(3)=FN
SET DA(2)=MN
SET DA(1)=AP
SET DA=MAP
SET IENS=$$IENS^DILF(.DA)
+69 SET AVALUE=$$GET1^DIQ(90505.115121,IENS,.01,"E")
+70 IF $TEXT(@(APNAME))'=""
DO @APNAME
+71 IF AVALUE'=""
SET AFMPARMS(FNAME,VALUE,APNAME,AVALUE)=""
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+72 ; Load description and executable code
+73 NEW X,DIC,Y,FX,FDES,FORD,FDESC,DA,IENS
+74 SET FNAME=""
SET FDESC=""
+75 FOR
SET FNAME=$ORDER(FILTER(FNAME))
IF FNAME=""
QUIT
Begin DoDot:1
+76 SET X=FNAME
SET DIC(0)="NZ"
SET DIC="^BQI(90506,"_FIEN_",3,"
DO ^DIC
+77 IF Y<0
QUIT
SET DA=$PIECE(Y,"^")
SET DA(1)=FIEN
SET IENS=$$IENS^DILF(.DA)
+78 SET FX=$$GET1^DIQ(90506.03,IENS,2,"I")
+79 IF FX'=""
XECUTE FX
+80 SET FDES=$$GET1^DIQ(90506.03,IENS,4,"I")
+81 SET FORD=$$GET1^DIQ(90506.03,IENS,.1,"I")
+82 IF FORD=""
QUIT
+83 IF FDES'=""
SET FDES(FORD)=FDES
End DoDot:1
+84 SET FORD=""
FOR
SET FORD=$ORDER(FDES(FORD))
IF FORD=""
QUIT
SET FDESC=FDESC_FDES(FORD)_"; "
+85 ;S FDESC=$E(FDESC,1,$L(FDESC)-2) ; Remove trailing "; "
+86 SET FDESC=$$TKO^BQIUL1(FDESC,"; ")
+87 IF $DATA(AFPARMS)
Begin DoDot:1
+88 NEW CAT,AVAL,TP,VALS,FDSC
+89 SET CAT=""
+90 FOR
SET CAT=$ORDER(FPARMS(CAT))
IF CAT=""
QUIT
IF FPARMS(CAT)'=""
IF $DATA(AFPARMS(CAT,FPARMS(CAT)))
Begin DoDot:2
+91 SET TP=""
+92 FOR
SET TP=$ORDER(AFPARMS(CAT,FPARMS(CAT),TP))
IF TP=""
QUIT
Begin DoDot:3
+93 SET AVAL=""
SET VALS=$$GDSC(TP,FIEN)
+94 FOR
SET AVAL=$ORDER(AFPARMS(CAT,FPARMS(CAT),TP,AVAL))
IF AVAL=""
QUIT
Begin DoDot:4
+95 SET VALS=VALS_AVAL_", "
End DoDot:4
+96 SET VALS=$$TKO^BQIUL1(VALS,", ")
End DoDot:3
+97 IF VALS'=""
SET FPARMS(CAT)=FPARMS(CAT)_" ("_VALS_")"
End DoDot:2
End DoDot:1
+98 IF $DATA(FMPARMS)
Begin DoDot:1
+99 SET FNAME=""
+100 FOR
SET FNAME=$ORDER(FMPARMS(FNAME))
IF FNAME=""
QUIT
Begin DoDot:2
+101 SET VAL=""
SET VALS=""
+102 FOR
SET VAL=$ORDER(FMPARMS(FNAME,VAL))
IF VAL=""
QUIT
Begin DoDot:3
+103 SET VALS=VALS_VAL_$$ADDAP(FNAME,VAL)_", "
End DoDot:3
+104 SET VALS=$$TKO^BQIUL1(VALS,", ")
+105 SET FPARMS(FNAME)=VALS
End DoDot:2
End DoDot:1
+106 IF FDESC["|"
Begin DoDot:1
+107 FOR
SET FDESC=$PIECE(FDESC,"|",1)_$GET(FPARMS($PIECE(FDESC,"|",2)))_$PIECE(FDESC,"|",3,99)
IF FDESC'["|"
QUIT
End DoDot:1
+108 IF FDESC'=""
SET FDESC=$$TKO^BQIUL1(FDESC,", ")
+109 QUIT FDESC
+110 ;
GVAL(PTYP,FILN,IENS,SRC,NM) ; EP - Get value of parameter/filter
+1 NEW VALUE,BQFIL
+2 IF PTYP="T"
Begin DoDot:1
+3 SET VALUE=$$GET1^DIQ(FILN,IENS,.03,"E")
+4 SET BQFIL=$$FILN^BQIDCDF(SRC,NM)
IF BQFIL=""
QUIT
+5 SET VALUE=$$GET1^DIQ(BQFIL,VALUE,.01,"E")
End DoDot:1
+6 IF PTYP'="T"
SET VALUE=$$GET1^DIQ(FILN,IENS,.02,"E")
+7 IF PTYP="D"
SET VALUE=$$UP^XLFSTR($$FMTE^XLFDT(VALUE,1))
+8 IF PTYP="R"
Begin DoDot:1
+9 SET VALUE=$$DATE^BQIUL1(VALUE)
+10 SET VALUE=$$UP^XLFSTR($$FMTE^XLFDT(VALUE,1))
End DoDot:1
+11 QUIT VALUE
+12 ;
GMVAL(PTYP,FILN,IENS,SRC,NM) ; EP - Get value for multiples
+1 NEW VALUE,BQFIL
+2 IF PTYP="T"
Begin DoDot:1
+3 SET VALUE=$$GET1^DIQ(FILN,IENS,.02,"E")
+4 SET BQFIL=$$FILN^BQIDCDF(SRC,NM)
IF BQFIL=""
QUIT
+5 SET VALUE=$$GET1^DIQ(BQFIL,VALUE,.01,"E")
End DoDot:1
+6 IF PTYP'="T"
SET VALUE=$$GET1^DIQ(FILN,IENS,.01,"E")
+7 QUIT VALUE
+8 ;
GDSC(CAT,FIEN) ; EP - Get filter description
+1 NEW X,DIC,Y,DA,IENS
+2 SET X=CAT
SET DIC(0)="NZ"
SET DIC="^BQI(90506,"_FIEN_",3,"
DO ^DIC
+3 IF Y<0
QUIT ""
+4 SET DA=$PIECE(Y,"^")
SET DA(1)=FIEN
SET IENS=$$IENS^DILF(.DA)
+5 SET FDSC=$$GET1^DIQ(90506.03,IENS,.09,"I")
+6 IF FDSC'=""
SET FDSC=FDSC_" "
+7 QUIT FDSC
+8 ;
ADDAP(FNM,VALUE) ; EP - Return associated parameters text for multiple filter
+1 NEW TP,AVAL,VALS
+2 SET (TP,VALS)=""
+3 FOR
SET TP=$ORDER(AFMPARMS(FNM,VALUE,TP))
IF TP=""
QUIT
Begin DoDot:1
+4 SET VALS=VALS_" ("_$$GDSC(TP,FIEN)
SET AVAL=""
Begin DoDot:2
+5 FOR
SET AVAL=$ORDER(AFMPARMS(FNM,VALUE,TP,AVAL))
IF AVAL=""
QUIT
Begin DoDot:3
+6 SET VALS=VALS_AVAL_", "
End DoDot:3
+7 SET VALS=$$TKO^BQIUL1(VALS,", ")_")"
End DoDot:2
End DoDot:1
+8 QUIT VALS
+9 ;
DXSTAT ; EP - Translate code to description for dx tag statuses
+1 SET AVALUE=$SELECT(AVALUE="A":"Accepted",AVALUE="P":"Proposed",AVALUE="N":"Not Accepted",AVALUE="V":"No Longer Valid",AVALUE="S":"Superseded",1:"")
+2 QUIT
+3 ;
MYPT(OWNR,MPIEN,ICDEF,PARMS,MPARMS) ;EP - Set up My Patients - System Generated Description
+1 ;
+2 ;Description: This tag gets called by DESCRIPTION EXECUTABLE code in 90506. The process is
+3 ; started from PEN^BQIPLDSC. It sets up the single field PARMS array and the
+4 ; multiple field MPARMS array with information found in the file 90505, node 7.
+5 ;
+6 ;Parameters:
+7 ; OWNR = Owner
+8 ; MPIEN = File 90505, Node 7 IEN
+9 ; ICDEF = ICARE DEFINITIONS Name
+10 ; PARMS = Array of Fields and Values (Updated By This Tag)
+11 ; MPARMS = Array of Multiple Fields and Values (Updated By This Tag)
+12 ;
+13 NEW DA,IENS,N,SOURCE
+14 ;Use the field defs from PATIENTS ASSIGNED TO since they are the same
SET SOURCE="PATIENTS ASSIGNED TO"
+15 SET N=0
FOR
SET N=$ORDER(^BQICARE(OWNR,7,MPIEN,10,N))
IF 'N
QUIT
Begin DoDot:1
+16 NEW DA,IENS,NAME,DESCEX,VALUE,PPIEN,PTYP,BQFIL
+17 SET DA(2)=OWNR
SET DA(1)=MPIEN
SET DA=N
SET IENS=$$IENS^DILF(.DA)
+18 SET NAME=$$GET1^DIQ(90505.08,IENS,.01,"E")
+19 ;
+20 SET PPIEN=$$PP^BQIDCDF(SOURCE)
+21 IF PPIEN
SET DESCEX=$$GET1^DIQ(90506,PPIEN,5,"I")
+22 SET PTYP=$$PTYP^BQIDCDF(SOURCE,NAME)
+23 IF PTYP="T"
Begin DoDot:2
+24 SET VALUE=$$GET1^DIQ(90505.08,IENS,.03,"E")
+25 SET BQFIL=$$FILN^BQIDCDF(SOURCE,NAME)
IF BQFIL=""
QUIT
+26 SET VALUE=$$GET1^DIQ(BQFIL,VALUE,.01,"E")
End DoDot:2
+27 IF PTYP'="T"
SET VALUE=$$GET1^DIQ(90505.08,IENS,.02,"E")
+28 ;
+29 ;Save Provider
+30 IF NAME="PROV"
Begin DoDot:2
+31 IF '$DATA(PARMS("PROV"))
SET PARMS("PROV")=VALUE
End DoDot:2
QUIT
+32 ;
+33 ;Save Single-Stored Specialty
+34 IF NAME="SPEC"
IF VALUE'=""
IF $GET(DESCEX)'=""
XECUTE DESCEX
+35 ;
+36 ;Handle Multiple Fields
+37 IF VALUE=""
IF $DATA(^BQICARE(OWNR,7,MPIEN,10,N,1))
Begin DoDot:2
+38 ;
+39 NEW MN
+40 SET MN=0
FOR
SET MN=$ORDER(^BQICARE(OWNR,7,MPIEN,10,N,1,MN))
IF 'MN
QUIT
Begin DoDot:3
+41 NEW DA,IENS,VALUE
+42 SET DA(3)=OWNR
SET DA(2)=MPIEN
SET DA(1)=N
SET DA=MN
SET IENS=$$IENS^DILF(.DA)
+43 IF PTYP="T"
Begin DoDot:4
+44 SET VALUE=$$GET1^DIQ(90505.81,IENS,.02,"E")
+45 SET BQFIL=$$FILN^BQIDCDF(SOURCE,NAME)
IF BQFIL=""
QUIT
+46 SET VALUE=$$GET1^DIQ(BQFIL,VALUE,.01,"E")
End DoDot:4
+47 IF PTYP'="T"
SET VALUE=$$GET1^DIQ(90505.81,IENS,.01,"E")
+48 IF VALUE'=""
IF $GET(DESCEX)'=""
XECUTE DESCEX
+49 SET MPARMS(NAME,VALUE)=""
End DoDot:3
End DoDot:2
QUIT
+50 ;
+51 ;Save Single fields
+52 SET PARMS(NAME)=VALUE
End DoDot:1
+53 ;
+54 IF $DATA(PARMS("VISITS"))
IF $DATA(PARMS("TMFRAME"))
Begin DoDot:1
+55 IF ICDEF="MY PATIENTS-PRIMARY"
DO PSVST("PRIM",$GET(PARMS("VISITS")),$GET(PARMS("TMFRAME")),.MPARMS)
+56 IF ICDEF="MY PATIENTS-PRIMARY/SECONDARY"
DO PSVST("PRSC",$GET(PARMS("VISITS")),$GET(PARMS("TMFRAME")),.MPARMS)
+57 KILL PARMS("VISITS"),PARMS("TMFRAME")
End DoDot:1
+58 QUIT
+59 ;
SPEC ;EP - Format Specialty provider
+1 IF NAME'="SPEC"
QUIT
+2 IF VALUE=""
QUIT
+3 NEW SPECNM
+4 SET SPECNM=$$GET1^DIQ(90360.3,VALUE,.01,"I")
+5 IF SPECNM=""
QUIT
+6 ;
+7 ;Save each Specialty name in the "TYPE" node so it gets included in the
+8 ;generated description. The "SPEC" entry also needs removed so it doesn't show
+9 ;up as well.
+10 IF $DATA(MPARMS("TYPE","SPEC"))
KILL MPARMS("TYPE","SPEC")
+11 SET MPARMS("TYPE",SPECNM)=""
+12 QUIT
+13 ;
PSVST(BQITYPE,BQIVST,BQITIME,BQIMPRM) ;EP - Assemble Primary/Secondary Provider Visit Checks
+1 ;
+2 ;Description: This tag receives primary or secondary visit check information and moves it into
+3 ; the multiple field "TYPE" node so it will be included with the other specialties.
+4 ;
+5 ;Parameters:
+6 ;BQITYPE = "PRIM" - Primary or "PRSC" - Primary/Secondary
+7 ;BQIVST = # of visits parameter
+8 ;BQITIME = Date Range
+9 ;BQIMPRM = Passed in MPARMS array. Gets updated with visit check description
+10 ;
+11 ;
+12 NEW STR
+13 IF BQITYPE=""!(BQIVST="")!(BQITIME="")
QUIT
+14 ;
+15 ;Remove Existing Entry
+16 KILL BQIMPRM("TYPE",BQITYPE)
+17 ;
+18 ;Assemble Visit Check Description
+19 SET STR=$SELECT(BQITYPE="PRIM":"PRIMARY VISIT PROVIDER",1:"PRIMARY/SECONDARY VISIT PROVIDER")
+20 SET STR=STR_" "_BQIVST_$SELECT(BQIVST>1:" VISITS",1:" VISIT")
+21 SET STR=STR_" IN "_$SELECT(BQITIME="T-24M":"2 YRS",BQITIME="T-12M":"1 YR",1:$PIECE(BQITIME,"T-",2))
+22 ;
+23 ;Save New Entry With Visit Check Description
+24 SET BQIMPRM("TYPE",STR)=""
+25 QUIT
