BQIPLDSC ;PRXM/HC/ALA-Panel Description Utility ; 19 Jan 2006 1:28 PM
;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66
;
Q
;
AGE ; Format FPARMS("AGE") or FMPARMS("AGE")
; Added the following line to replace the subsequent code for PR_0124
I $D(FPARMS("AGE")) D Q
. N AGE,EXT,OP
. S AGE=FPARMS("AGE")
. S EXT=$S($E(AGE)="'":2,1:1),OP=$E(AGE,1,EXT),AGE=$E(AGE,EXT+1,99)
. S AGE=$S(OP="=":AGE,OP=">":"older than "_AGE,OP="<":"younger than "_AGE,OP="'<":AGE_" or older",1:AGE_" or younger")
. I AGE["YRS" S AGE=$P(AGE,"YRS")_" years"_$P(AGE,"YRS",2,99)
. I AGE["MOS" S AGE=$P(AGE,"MOS")_" months"_$P(AGE,"MOS",2,99)
. I AGE["DYS" S AGE=$P(AGE,"DYS")_" days"_$P(AGE,"DYS",2,99)
. S FPARMS("AGE")=AGE
N AGE,AGE1,AGE2,I
S AGE1=$O(FMPARMS("AGE","")) Q:AGE1=""
S AGE2=$O(FMPARMS("AGE",AGE1)) Q:AGE2=""
I $E(AGE1)="'" S AGE="between (inclusive) "_$E(AGE1,3,99)_" and "_$E(AGE2,3,99)
I $E(AGE1)'="'" S AGE="younger than "_$E(AGE1,2,99)_" or older than "_$E(AGE2,2,99)
F I=1,2 I AGE["YRS" S AGE=$P(AGE,"YRS")_" years"_$P(AGE,"YRS",2,99)
F I=1,2 I AGE["MOS" S AGE=$P(AGE,"MOS")_" months"_$P(AGE,"MOS",2,99)
F I=1,2 I AGE["DYS" S AGE=$P(AGE,"DYS")_" days"_$P(AGE,"DYS",2,99)
S FPARMS("AGE")=AGE K FMPARMS("AGE")
Q
;
PLIDEN ; Format FPARMS("PLIDEN") or FMPARMS("PLIDEN")
N PLOWNR
I $D(FPARMS("PLIDEN")) D
. S PLOWNR=$P(FPARMS("PLIDEN"),$C(26),1),PLOWNR=$$GET1^DIQ(200,PLOWNR_",",.01,"E")
. S FPARMS("PLIDEN")=$P(FPARMS("PLIDEN"),$C(26),2)_" "_PLOWNR
I $D(FMPARMS("PLIDEN")) D
. N PLIEN,PLARR
. S PLIEN=""
. F S PLIEN=$O(FMPARMS("PLIDEN",PLIEN)) Q:PLIEN="" D
.. S PLOWNR=$P(PLIEN,$C(26),1),PLOWNR=$$GET1^DIQ(200,PLOWNR_",",.01,"E")
.. S PLARR($P(PLIEN,$C(26),2)_" "_PLOWNR)=""
. K FMPARMS("PLIDEN")
. M FMPARMS("PLIDEN")=PLARR
Q
;
BEN ; Format FPARMS("BEN") or FMPARMS("BEN")
Q ;Disabled
I $D(FPARMS("BEN")) D
. S FPARMS("BEN")=$$GET1^DIQ(9999999.25,FPARMS("BEN")_",",.01,"E")
I $D(FMPARMS("BEN")) D
. N PLIEN,PLBEN
. S PLIEN=""
. F S PLIEN=$O(FMPARMS("BEN",PLIEN)) Q:PLIEN="" D
.. S PLBEN=$$GET1^DIQ(9999999.25,PLIEN_",",.01,"E")
.. S PLARR(PLBEN)=""
. K FMPARMS("BEN")
. M FMPARMS("BEN")=PLARR
Q
;
REG ; Format FPARMS("REG")
N REGIEN,REGNMSP
I '$D(PARMS("REG")) Q
S REGIEN=$O(^BQI(90507,"B",PARMS("REG"),""))
I REGIEN="" Q
S REGNMSP=$$GET1^DIQ(90507,REGIEN_",",.13,"E")
I REGNMSP'="" S PARMS("NMSP")=REGNMSP
I $G(PARMS("SUBREG"))'="" D
. N SBIEN,SBREG
. S SBIEN=0 F S SBIEN=$O(^BQI(90507,SBIEN)) Q:'SBIEN D
.. S SBREG=$P($G(^BQI(90507,SBIEN,0)),U,9)
.. I SBREG=PARMS("SUBREG") D
... S REGNMSP=$$GET1^DIQ(90507,SBIEN_",",.13,"E")
... I REGNMSP'="" S PARMS("NMSP")=REGNMSP
;S PARMS("REG")=REGNMSP_PARMS("REG")
Q
;
STAT(STAT) ;EP - Register Status
I $G(STAT)="" Q
I '$D(PARMS("STATUS")) S PARMS("STATUS")=" Status: "
I PARMS("STATUS")'=" Status: " S PARMS("STATUS")=PARMS("STATUS")_", "
S PARMS("STATUS")=PARMS("STATUS")_STAT
Q
;
SCH ;EP - Scheduled Appointments
NEW FDT,EDT,OSTAT,STAT,II
S RFROM=$G(PARMS("RFROM")),RTHRU=$G(PARMS("RTHRU"))
S FROM=$G(PARMS("FROM")),THRU=$G(PARMS("THRU"))
S FDT=$S($G(RFROM)'="":RFROM,1:$G(FROM))
S EDT=$S($G(RTHRU)'="":RTHRU,1:$G(THRU))
S PARMS("FROM")=FDT,PARMS("THRU")=EDT
I NAME="APTYPE" D
. Q:VALUE=""
. I '$D(PARMS("APTYPE")),'$D(MPARMS("APTYPE")) S VALUE=" Status "_VALUE
I NAME="APSTAT" D
. Q:VALUE=""
. ; Remove comments if status description should be displayed
. ; D TAB^BQIUTB(.OSTAT,"APSTAT")
. ; F II=1:1 S STAT=@OSTAT@(II) Q:STAT=$C(31) S STAT($P(STAT,U))=$P(STAT,U,2)
. ; I $D(STAT(VALUE)) S VALUE=$P(STAT(VALUE),$C(30))
. S VALUE=$$SCHTP(VALUE)
. I '$D(PARMS("APSTAT")),'$D(MPARMS("APSTAT")) S VALUE=" Status "_VALUE
. I $D(MPARMS("APSTAT"," Status "_VALUE)) S VALUE=" Status "_VALUE
Q
;
SCHTP(STATUS) ;EP - Convert appointment status code to appointment type
NEW ST,APTYPE,I,PC,VAL,TPIEN
S VAL=STATUS
S APTYPE=$O(^BQI(90506,PPIEN,3,"B","APTYPE","")) I APTYPE="" Q VAL
S ST="" F S ST=$O(^BQI(90506,PPIEN,3,APTYPE,3,"AC",ST)) Q:ST="" D
. F I=1:1:$L(ST,"~") S PC=$P(ST,"~",I) I PC=("APSTAT="_VAL) D Q
.. S TPIEN=$O(^BQI(90506,PPIEN,3,APTYPE,3,"AC",ST,""))
.. I TPIEN'="" S VAL=$P($G(^BQI(90506,PPIEN,3,APTYPE,3,TPIEN,0)),U) S:VAL="" VAL=STATUS
Q VAL
;
DXCAT ;EP - Diagnosis Category
; Only reformat description with designated operand
I $G(FPARMS("DXOP"))="" Q
; If only a single Dx Category was identified operand is meaningless
I '$D(FMPARMS("DXCAT")) Q
S FPARMS("DXOP")=$S(FPARMS("DXOP")="&":", AND ",1:", OR ")
N DX,APM
S (DX,APM)="",FPARMS("DXCAT")=""
F S DX=$O(FMPARMS("DXCAT",DX)) Q:DX="" D
. I $D(AFMPARMS("DXCAT",DX)) D
.. S APM=$$ADDAP^BQIPLDS1("DXCAT",DX)
.. ;S APM=$P(APM,"(")_"(Status "_$P(APM,"(",2,99)
. I $O(FMPARMS("DXCAT",DX))="" S FPARMS("DXCAT")=FPARMS("DXCAT")_DX_APM Q
. S FPARMS("DXCAT")=FPARMS("DXCAT")_DX_APM_FPARMS("DXOP")
K FMPARMS("DXCAT"),AFMPARMS("DXCAT")
Q
;
NVIS ; Format FPARMS("NUMVIS") or FMPARMS("NUMVIS")
;
I $D(FPARMS("NUMVIS")) D Q
. N NUMVIS,EXT,OP
. I FPARMS("NUMVIS")?1N.N S FPARMS("NUMVIS")="="_FPARMS("NUMVIS") ;***Replace***
. S NUMVIS=FPARMS("NUMVIS")
. S EXT=$S($E(NUMVIS)="'":2,1:1),OP=$E(NUMVIS,1,EXT),NUMVIS=$E(NUMVIS,EXT+1,99)
. S NUMVIS=$S(OP="=":NUMVIS,OP=">":"more than "_NUMVIS,OP="<":"less than "_NUMVIS,OP="'<":NUMVIS_" or more",1:NUMVIS_" or less")
. S FPARMS("NUMVIS")=NUMVIS
N NUMVIS,NUMVIS1,NUMVIS2,I
S NUMVIS1=$O(FMPARMS("NUMVIS","")) Q:NUMVIS1=""
S NUMVIS2=$O(FMPARMS("NUMVIS",NUMVIS1)) Q:NUMVIS2=""
I $E(NUMVIS1)="'" S NUMVIS="between (inclusive) "_$E(NUMVIS1,3,99)_" and "_$E(NUMVIS2,3,99)
I $E(NUMVIS1)'="'",$E(NUMVIS1)'="=" S NUMVIS="less than "_$E(NUMVIS1,2,99)_" or more than "_$E(NUMVIS2,2,99)
I $G(NUMVIS)'="" S FPARMS("NUMVIS")=NUMVIS K FMPARMS("NUMVIS")
Q
;
EHPL ;EP - Format EHR Personal List
; This is defined as a numeric field so PARMS and MPARMS are not created - data all contained in VALUE
N EHCT,EHPLIEN,EHPL,PLVAL
F EHCT=1:1:$L(VALUE,$C(29)) S EHPLIEN=$P(VALUE,$C(29),EHCT) Q:EHPLIEN="" D
. S EHPL=$$GETNAME^BEHOPTP2(EHPLIEN)
. S PLVAL=$G(PLVAL)_EHPL_","
S PLVAL=$$TKO^BQIUL1(PLVAL,",")
S VALUE=PLVAL
Q
;
PEN(OWNR,PLIEN,DESC) ;EP - Format Panel Generated Description
;
;Description
; The panel description is based on the values of the parameters
;
NEW DA,IENS,TYPE,SOURCE,PPIEN,ODESC,NDESC,PARMS,MPARMS,N,NAME,OPARMS,PTYP,VALUE
NEW BQFIL,VAL,VALS,PDESC,FILTER
;
S NDESC="",FILTER=""
S DA(1)=OWNR,DA=PLIEN,IENS=$$IENS^DILF(.DA)
S TYPE=$$GET1^DIQ(90505.01,IENS,.03,"I")
S SOURCE=$$GET1^DIQ(90505.01,IENS,.11,"I")
;
;My Patients
;
I TYPE="Y" D Q
. NEW FILTER,ICDEF,ICEXE,ICIEN,MPARMS,MPIEN,NAME,NDESC,PARMS,PDESC,SOURCE,VAL,VALS
. S FILTER=""
. ;
. S MPIEN=0 F S MPIEN=$O(^BQICARE(OWNR,7,MPIEN)) Q:'MPIEN I $G(^BQICARE(OWNR,7,MPIEN,2))'="" D
.. ;
.. ;Pull iCare Definition Executable
.. S ICDEF=$G(^BQICARE(OWNR,7,MPIEN,0)) Q:ICDEF=""
.. S ICIEN=$O(^BQI(90506,"B",ICDEF,"")) Q:ICIEN=""
.. S ICEXE=$G(^BQI(90506,ICIEN,5))
.. ;
.. ;Run Executable Statement
.. I ICEXE]"" X ICEXE
. ;
. ;Convert Multiple Values into one Value
. I $D(MPARMS) D
.. S NAME=""
.. F S NAME=$O(MPARMS(NAME)) Q:NAME="" D
... S VAL="",VALS=""
... F S VAL=$O(MPARMS(NAME,VAL)) Q:VAL="" S VALS=VALS_VAL_", "
... S VALS=$$TKO^BQIUL1(VALS,", ")
... S PARMS(NAME)=VALS
. ;
. ;Define Description Format
. S NDESC="My Patients where provider |PROV| specialties are |TYPE|."
. ;
. ;Assemble Filter
. I $O(^BQICARE(OWNR,1,PLIEN,15,0)) D I $G(BMXSEC)'="" Q
.. S FILTER=$$FILTER^BQIPLDS1(OWNR,PLIEN)
.. I $G(BMXSEC)'="" Q
.. I $G(NDESC)="" D FILDES(FILTER,1) Q
.. I '$F(NDESC,"|") S DESC(1,0)=NDESC D FILDES(FILTER,2) Q
. ;
. ;Assemble Generated Description
. F Q:'$F(NDESC,"|") D PRS
. S DESC(1,0)=$G(PDESC) D FILDES(FILTER,2)
. Q
;
;Manual Patients
;
I TYPE="M" S DESC(1,0)="The patients who were selected manually" Q
;
;QMAN Template
;
I TYPE="Q" D Q
. ;S DESC(1,0)="The patients who were selected by QMAN Template "_$P(^DIBT(SOURCE,0),U,1)
. S DESC(1,0)="Search Template "_$P($G(^DIBT(SOURCE,0)),U,1)
. I $O(^BQICARE(OWNR,1,PLIEN,15,0)) D I $G(BMXSEC)'="" Q
.. ;S FILTER=$$FILTER(OWNR,PLIEN,2,4)
.. S FILTER=$$FILTER^BQIPLDS1(OWNR,PLIEN)
.. I $G(BMXSEC)'="" Q
.. D FILDES(FILTER,2)
;
I SOURCE="" Q
;
S PPIEN=$$PP^BQIDCDF(SOURCE) I PPIEN=-1 Q
S NDESC=$$GET1^DIQ(90506,PPIEN,4,"E")
;
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,DESCEX,VALUE,PPIEN,PTYP
. S DA(2)=OWNR,DA(1)=PLIEN,DA=N,IENS=$$IENS^DILF(.DA)
. S NAME=$$GET1^DIQ(90505.02,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.02,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.02,IENS,.02,"E")
. ;
. ;Save unformatted parameter values
. S OPARMS(NAME)=VALUE
. ;
. 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))
. I VALUE'="" D Q
.. I $G(DESCEX)'="" X DESCEX
.. S PARMS(NAME)=VALUE
. I VALUE="" D
.. Q:'$D(^BQICARE(OWNR,1,PLIEN,10,N,1))
.. NEW MN
.. S MN=0 F S MN=$O(^BQICARE(OWNR,1,PLIEN,10,N,1,MN)) Q:'MN D
... NEW DA,IENS,VALUE
... S DA(3)=OWNR,DA(2)=PLIEN,DA(1)=N,DA=MN,IENS=$$IENS^DILF(.DA)
... I PTYP="T" D
.... S VALUE=$$GET1^DIQ(90505.21,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.21,IENS,.01,"E")
... I VALUE'="",$G(DESCEX)'="" X DESCEX
... I VALUE]"" S MPARMS(NAME,VALUE)=""
;
;Special Code to Assemble Primary/Secondary Provider Information into "TYPE" node
I $D(MPARMS("TYPE","PRIM")) D PSVST^BQIPLDS1("PRIM",$G(OPARMS("PVISITS")),$G(OPARMS("PTMFRAME")),.MPARMS)
I $D(MPARMS("TYPE","PRSC")) D PSVST^BQIPLDS1("PRSC",$G(OPARMS("PSVISITS")),$G(OPARMS("PSTMFRAM")),.MPARMS)
;
I $O(^BQICARE(OWNR,1,PLIEN,15,0)) D I $G(BMXSEC)'="" Q
. S FILTER=$$FILTER^BQIPLDS1(OWNR,PLIEN)
. I $G(BMXSEC)'="" Q
I $G(NDESC)="" D FILDES(FILTER,1) Q
I '$F(NDESC,"|") S DESC(1,0)=NDESC D FILDES(FILTER,2) Q
;
I $D(MPARMS) D
. S NAME=""
. F S NAME=$O(MPARMS(NAME)) Q:NAME="" D
.. S VAL="",VALS=""
.. F S VAL=$O(MPARMS(NAME,VAL)) Q:VAL="" S VALS=VALS_VAL_", "
.. S VALS=$$TKO^BQIUL1(VALS,", ")
.. S PARMS(NAME)=VALS
;
S ODESC=NDESC
F Q:'$F(NDESC,"|") D PRS
S DESC(1,0)=PDESC D FILDES(FILTER,2)
Q
;
PRS ; Parse description
S NDESC=$P(NDESC,"|",1)_$G(PARMS($P(NDESC,"|",2)))_$P(NDESC,"|",3,99)
S PDESC=NDESC
Q
;
FILDES(FILTER,ENT) ;EP - Load filter description in DESC()
N PC
I FILTER'="" D
. ;S FILTER="Panel filtered by: "_FILTER
. I '$D(ENT) S ENT=$O(DESC(""),-1)+1
. F I=1:1:$L(FILTER,"; ") S PC=$P(FILTER,"; ",I) I PC'="" S DESC(ENT,0)=PC_"; ",ENT=ENT+1
. S ENT=ENT-1
. I $D(DESC(ENT,0)) S DESC(ENT,0)=$$TKO^BQIUL1(DESC(ENT,0),"; ")
Q
;
MEN(OWNR,PREF) ;EP -- Format my patients preferences generated description
;
;Description
; The my patients preferences description is based on the values of the parameters
;
NEW DA,IENS,SOURCE,PPIEN,DESC,ODESC,NDESC,PARMS,MPARMS,N,NAME,PTYP,VALUE
NEW BQFIL,VAL,VALS
S DESC="",NDESC=""
S DA(1)=OWNR,DA=PREF,IENS=$$IENS^DILF(.DA)
S SOURCE=$$GET1^DIQ(90505.07,IENS,.01,"E")
;
S PPIEN=$$PP^BQIDCDF(SOURCE) I PPIEN=-1 Q ""
S DESC=$$GET1^DIQ(90506,PPIEN,4,"E")
I DESC="" Q ""
;
; Get parameters from my patient definition
S N=0 F S N=$O(^BQICARE(OWNR,7,PREF,10,N)) Q:'N D
. NEW DA,IENS,NAME,VALUE
. S DA(2)=OWNR,DA(1)=PREF,DA=N,IENS=$$IENS^DILF(.DA)
. S NAME=$$GET1^DIQ(90505.08,IENS,.01,"E")
. 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")
. 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))
. I NAME="SPEC",VALUE'="" D Q:VALUE=""
.. N SPECNM
.. S SPECNM=$$GET1^DIQ(90360.3,VALUE,.01,"I") ;Mnemonic
.. S VALUE=SPECNM
. I VALUE'="" S PARMS(NAME)=VALUE Q
. I VALUE="" D
.. Q:'$D(^BQICARE(OWNR,7,PREF,10,N,1))
.. NEW MN
.. S MN=0 F S MN=$O(^BQICARE(OWNR,7,PREF,10,N,1,MN)) Q:'MN D
... NEW DA,IENS,VALUE
... S DA(3)=OWNR,DA(2)=PREF,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 NAME="SPEC",VALUE'="" D Q:VALUE=""
.... N SPECNM
.... S SPECNM=$$GET1^DIQ(90360.3,VALUE,.01,"I") ;Mnemonic
.... S VALUE=SPECNM
... S MPARMS(NAME,VALUE)=""
;
I '$F(DESC,"|") Q ""
I $D(PARMS)<10 Q ""
;
I $D(MPARMS) D
. S NAME=""
. F S NAME=$O(MPARMS(NAME)) Q:NAME="" D
.. S VAL="",VALS=""
.. F S VAL=$O(MPARMS(NAME,VAL)) Q:VAL="" S VALS=VALS_VAL_", "
.. S VALS=$$TKO^BQIUL1(VALS,", ")
.. S PARMS(NAME)=VALS
;
S ODESC=DESC,NDESC=DESC
F Q:'$F(NDESC,"|") D PRS
Q PDESC
BQIPLDSC ;PRXM/HC/ALA-Panel Description Utility ; 19 Jan 2006 1:28 PM
+1 ;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66
+2 ;
+3 QUIT
+4 ;
AGE ; Format FPARMS("AGE") or FMPARMS("AGE")
+1 ; Added the following line to replace the subsequent code for PR_0124
+2 IF $DATA(FPARMS("AGE"))
Begin DoDot:1
+3 NEW AGE,EXT,OP
+4 SET AGE=FPARMS("AGE")
+5 SET EXT=$SELECT($EXTRACT(AGE)="'":2,1:1)
SET OP=$EXTRACT(AGE,1,EXT)
SET AGE=$EXTRACT(AGE,EXT+1,99)
+6 SET AGE=$SELECT(OP="=":AGE,OP=">":"older than "_AGE,OP="<":"younger than "_AGE,OP="'<":AGE_" or older",1:AGE_" or younger")
+7 IF AGE["YRS"
SET AGE=$PIECE(AGE,"YRS")_" years"_$PIECE(AGE,"YRS",2,99)
+8 IF AGE["MOS"
SET AGE=$PIECE(AGE,"MOS")_" months"_$PIECE(AGE,"MOS",2,99)
+9 IF AGE["DYS"
SET AGE=$PIECE(AGE,"DYS")_" days"_$PIECE(AGE,"DYS",2,99)
+10 SET FPARMS("AGE")=AGE
End DoDot:1
QUIT
+11 NEW AGE,AGE1,AGE2,I
+12 SET AGE1=$ORDER(FMPARMS("AGE",""))
IF AGE1=""
QUIT
+13 SET AGE2=$ORDER(FMPARMS("AGE",AGE1))
IF AGE2=""
QUIT
+14 IF $EXTRACT(AGE1)="'"
SET AGE="between (inclusive) "_$EXTRACT(AGE1,3,99)_" and "_$EXTRACT(AGE2,3,99)
+15 IF $EXTRACT(AGE1)'="'"
SET AGE="younger than "_$EXTRACT(AGE1,2,99)_" or older than "_$EXTRACT(AGE2,2,99)
+16 FOR I=1,2
IF AGE["YRS"
SET AGE=$PIECE(AGE,"YRS")_" years"_$PIECE(AGE,"YRS",2,99)
+17 FOR I=1,2
IF AGE["MOS"
SET AGE=$PIECE(AGE,"MOS")_" months"_$PIECE(AGE,"MOS",2,99)
+18 FOR I=1,2
IF AGE["DYS"
SET AGE=$PIECE(AGE,"DYS")_" days"_$PIECE(AGE,"DYS",2,99)
+19 SET FPARMS("AGE")=AGE
KILL FMPARMS("AGE")
+20 QUIT
+21 ;
PLIDEN ; Format FPARMS("PLIDEN") or FMPARMS("PLIDEN")
+1 NEW PLOWNR
+2 IF $DATA(FPARMS("PLIDEN"))
Begin DoDot:1
+3 SET PLOWNR=$PIECE(FPARMS("PLIDEN"),$CHAR(26),1)
SET PLOWNR=$$GET1^DIQ(200,PLOWNR_",",.01,"E")
+4 SET FPARMS("PLIDEN")=$PIECE(FPARMS("PLIDEN"),$CHAR(26),2)_" "_PLOWNR
End DoDot:1
+5 IF $DATA(FMPARMS("PLIDEN"))
Begin DoDot:1
+6 NEW PLIEN,PLARR
+7 SET PLIEN=""
+8 FOR
SET PLIEN=$ORDER(FMPARMS("PLIDEN",PLIEN))
IF PLIEN=""
QUIT
Begin DoDot:2
+9 SET PLOWNR=$PIECE(PLIEN,$CHAR(26),1)
SET PLOWNR=$$GET1^DIQ(200,PLOWNR_",",.01,"E")
+10 SET PLARR($PIECE(PLIEN,$CHAR(26),2)_" "_PLOWNR)=""
End DoDot:2
+11 KILL FMPARMS("PLIDEN")
+12 MERGE FMPARMS("PLIDEN")=PLARR
End DoDot:1
+13 QUIT
+14 ;
BEN ; Format FPARMS("BEN") or FMPARMS("BEN")
+1 ;Disabled
QUIT
+2 IF $DATA(FPARMS("BEN"))
Begin DoDot:1
+3 SET FPARMS("BEN")=$$GET1^DIQ(9999999.25,FPARMS("BEN")_",",.01,"E")
End DoDot:1
+4 IF $DATA(FMPARMS("BEN"))
Begin DoDot:1
+5 NEW PLIEN,PLBEN
+6 SET PLIEN=""
+7 FOR
SET PLIEN=$ORDER(FMPARMS("BEN",PLIEN))
IF PLIEN=""
QUIT
Begin DoDot:2
+8 SET PLBEN=$$GET1^DIQ(9999999.25,PLIEN_",",.01,"E")
+9 SET PLARR(PLBEN)=""
End DoDot:2
+10 KILL FMPARMS("BEN")
+11 MERGE FMPARMS("BEN")=PLARR
End DoDot:1
+12 QUIT
+13 ;
REG ; Format FPARMS("REG")
+1 NEW REGIEN,REGNMSP
+2 IF '$DATA(PARMS("REG"))
QUIT
+3 SET REGIEN=$ORDER(^BQI(90507,"B",PARMS("REG"),""))
+4 IF REGIEN=""
QUIT
+5 SET REGNMSP=$$GET1^DIQ(90507,REGIEN_",",.13,"E")
+6 IF REGNMSP'=""
SET PARMS("NMSP")=REGNMSP
+7 IF $GET(PARMS("SUBREG"))'=""
Begin DoDot:1
+8 NEW SBIEN,SBREG
+9 SET SBIEN=0
FOR
SET SBIEN=$ORDER(^BQI(90507,SBIEN))
IF 'SBIEN
QUIT
Begin DoDot:2
+10 SET SBREG=$PIECE($GET(^BQI(90507,SBIEN,0)),U,9)
+11 IF SBREG=PARMS("SUBREG")
Begin DoDot:3
+12 SET REGNMSP=$$GET1^DIQ(90507,SBIEN_",",.13,"E")
+13 IF REGNMSP'=""
SET PARMS("NMSP")=REGNMSP
End DoDot:3
End DoDot:2
End DoDot:1
+14 ;S PARMS("REG")=REGNMSP_PARMS("REG")
+15 QUIT
+16 ;
STAT(STAT) ;EP - Register Status
+1 IF $GET(STAT)=""
QUIT
+2 IF '$DATA(PARMS("STATUS"))
SET PARMS("STATUS")=" Status: "
+3 IF PARMS("STATUS")'=" Status: "
SET PARMS("STATUS")=PARMS("STATUS")_", "
+4 SET PARMS("STATUS")=PARMS("STATUS")_STAT
+5 QUIT
+6 ;
SCH ;EP - Scheduled Appointments
+1 NEW FDT,EDT,OSTAT,STAT,II
+2 SET RFROM=$GET(PARMS("RFROM"))
SET RTHRU=$GET(PARMS("RTHRU"))
+3 SET FROM=$GET(PARMS("FROM"))
SET THRU=$GET(PARMS("THRU"))
+4 SET FDT=$SELECT($GET(RFROM)'="":RFROM,1:$GET(FROM))
+5 SET EDT=$SELECT($GET(RTHRU)'="":RTHRU,1:$GET(THRU))
+6 SET PARMS("FROM")=FDT
SET PARMS("THRU")=EDT
+7 IF NAME="APTYPE"
Begin DoDot:1
+8 IF VALUE=""
QUIT
+9 IF '$DATA(PARMS("APTYPE"))
IF '$DATA(MPARMS("APTYPE"))
SET VALUE=" Status "_VALUE
End DoDot:1
+10 IF NAME="APSTAT"
Begin DoDot:1
+11 IF VALUE=""
QUIT
+12 ; Remove comments if status description should be displayed
+13 ; D TAB^BQIUTB(.OSTAT,"APSTAT")
+14 ; F II=1:1 S STAT=@OSTAT@(II) Q:STAT=$C(31) S STAT($P(STAT,U))=$P(STAT,U,2)
+15 ; I $D(STAT(VALUE)) S VALUE=$P(STAT(VALUE),$C(30))
+16 SET VALUE=$$SCHTP(VALUE)
+17 IF '$DATA(PARMS("APSTAT"))
IF '$DATA(MPARMS("APSTAT"))
SET VALUE=" Status "_VALUE
+18 IF $DATA(MPARMS("APSTAT"," Status "_VALUE))
SET VALUE=" Status "_VALUE
End DoDot:1
+19 QUIT
+20 ;
SCHTP(STATUS) ;EP - Convert appointment status code to appointment type
+1 NEW ST,APTYPE,I,PC,VAL,TPIEN
+2 SET VAL=STATUS
+3 SET APTYPE=$ORDER(^BQI(90506,PPIEN,3,"B","APTYPE",""))
IF APTYPE=""
QUIT VAL
+4 SET ST=""
FOR
SET ST=$ORDER(^BQI(90506,PPIEN,3,APTYPE,3,"AC",ST))
IF ST=""
QUIT
Begin DoDot:1
+5 FOR I=1:1:$LENGTH(ST,"~")
SET PC=$PIECE(ST,"~",I)
IF PC=("APSTAT="_VAL)
Begin DoDot:2
+6 SET TPIEN=$ORDER(^BQI(90506,PPIEN,3,APTYPE,3,"AC",ST,""))
+7 IF TPIEN'=""
SET VAL=$PIECE($GET(^BQI(90506,PPIEN,3,APTYPE,3,TPIEN,0)),U)
IF VAL=""
SET VAL=STATUS
End DoDot:2
QUIT
End DoDot:1
+8 QUIT VAL
+9 ;
DXCAT ;EP - Diagnosis Category
+1 ; Only reformat description with designated operand
+2 IF $GET(FPARMS("DXOP"))=""
QUIT
+3 ; If only a single Dx Category was identified operand is meaningless
+4 IF '$DATA(FMPARMS("DXCAT"))
QUIT
+5 SET FPARMS("DXOP")=$SELECT(FPARMS("DXOP")="&":", AND ",1:", OR ")
+6 NEW DX,APM
+7 SET (DX,APM)=""
SET FPARMS("DXCAT")=""
+8 FOR
SET DX=$ORDER(FMPARMS("DXCAT",DX))
IF DX=""
QUIT
Begin DoDot:1
+9 IF $DATA(AFMPARMS("DXCAT",DX))
Begin DoDot:2
+10 SET APM=$$ADDAP^BQIPLDS1("DXCAT",DX)
+11 ;S APM=$P(APM,"(")_"(Status "_$P(APM,"(",2,99)
End DoDot:2
+12 IF $ORDER(FMPARMS("DXCAT",DX))=""
SET FPARMS("DXCAT")=FPARMS("DXCAT")_DX_APM
QUIT
+13 SET FPARMS("DXCAT")=FPARMS("DXCAT")_DX_APM_FPARMS("DXOP")
End DoDot:1
+14 KILL FMPARMS("DXCAT"),AFMPARMS("DXCAT")
+15 QUIT
+16 ;
NVIS ; Format FPARMS("NUMVIS") or FMPARMS("NUMVIS")
+1 ;
+2 IF $DATA(FPARMS("NUMVIS"))
Begin DoDot:1
+3 NEW NUMVIS,EXT,OP
+4 ;***Replace***
IF FPARMS("NUMVIS")?1N.N
SET FPARMS("NUMVIS")="="_FPARMS("NUMVIS")
+5 SET NUMVIS=FPARMS("NUMVIS")
+6 SET EXT=$SELECT($EXTRACT(NUMVIS)="'":2,1:1)
SET OP=$EXTRACT(NUMVIS,1,EXT)
SET NUMVIS=$EXTRACT(NUMVIS,EXT+1,99)
+7 SET NUMVIS=$SELECT(OP="=":NUMVIS,OP=">":"more than "_NUMVIS,OP="<":"less than "_NUMVIS,OP="'<":NUMVIS_" or more",1:NUMVIS_" or less")
+8 SET FPARMS("NUMVIS")=NUMVIS
End DoDot:1
QUIT
+9 NEW NUMVIS,NUMVIS1,NUMVIS2,I
+10 SET NUMVIS1=$ORDER(FMPARMS("NUMVIS",""))
IF NUMVIS1=""
QUIT
+11 SET NUMVIS2=$ORDER(FMPARMS("NUMVIS",NUMVIS1))
IF NUMVIS2=""
QUIT
+12 IF $EXTRACT(NUMVIS1)="'"
SET NUMVIS="between (inclusive) "_$EXTRACT(NUMVIS1,3,99)_" and "_$EXTRACT(NUMVIS2,3,99)
+13 IF $EXTRACT(NUMVIS1)'="'"
IF $EXTRACT(NUMVIS1)'="="
SET NUMVIS="less than "_$EXTRACT(NUMVIS1,2,99)_" or more than "_$EXTRACT(NUMVIS2,2,99)
+14 IF $GET(NUMVIS)'=""
SET FPARMS("NUMVIS")=NUMVIS
KILL FMPARMS("NUMVIS")
+15 QUIT
+16 ;
EHPL ;EP - Format EHR Personal List
+1 ; This is defined as a numeric field so PARMS and MPARMS are not created - data all contained in VALUE
+2 NEW EHCT,EHPLIEN,EHPL,PLVAL
+3 FOR EHCT=1:1:$LENGTH(VALUE,$CHAR(29))
SET EHPLIEN=$PIECE(VALUE,$CHAR(29),EHCT)
IF EHPLIEN=""
QUIT
Begin DoDot:1
+4 SET EHPL=$$GETNAME^BEHOPTP2(EHPLIEN)
+5 SET PLVAL=$GET(PLVAL)_EHPL_","
End DoDot:1
+6 SET PLVAL=$$TKO^BQIUL1(PLVAL,",")
+7 SET VALUE=PLVAL
+8 QUIT
+9 ;
PEN(OWNR,PLIEN,DESC) ;EP - Format Panel Generated Description
+1 ;
+2 ;Description
+3 ; The panel description is based on the values of the parameters
+4 ;
+5 NEW DA,IENS,TYPE,SOURCE,PPIEN,ODESC,NDESC,PARMS,MPARMS,N,NAME,OPARMS,PTYP,VALUE
+6 NEW BQFIL,VAL,VALS,PDESC,FILTER
+7 ;
+8 SET NDESC=""
SET FILTER=""
+9 SET DA(1)=OWNR
SET DA=PLIEN
SET IENS=$$IENS^DILF(.DA)
+10 SET TYPE=$$GET1^DIQ(90505.01,IENS,.03,"I")
+11 SET SOURCE=$$GET1^DIQ(90505.01,IENS,.11,"I")
+12 ;
+13 ;My Patients
+14 ;
+15 IF TYPE="Y"
Begin DoDot:1
+16 NEW FILTER,ICDEF,ICEXE,ICIEN,MPARMS,MPIEN,NAME,NDESC,PARMS,PDESC,SOURCE,VAL,VALS
+17 SET FILTER=""
+18 ;
+19 SET MPIEN=0
FOR
SET MPIEN=$ORDER(^BQICARE(OWNR,7,MPIEN))
IF 'MPIEN
QUIT
IF $GET(^BQICARE(OWNR,7,MPIEN,2))'=""
Begin DoDot:2
+20 ;
+21 ;Pull iCare Definition Executable
+22 SET ICDEF=$GET(^BQICARE(OWNR,7,MPIEN,0))
IF ICDEF=""
QUIT
+23 SET ICIEN=$ORDER(^BQI(90506,"B",ICDEF,""))
IF ICIEN=""
QUIT
+24 SET ICEXE=$GET(^BQI(90506,ICIEN,5))
+25 ;
+26 ;Run Executable Statement
+27 IF ICEXE]""
XECUTE ICEXE
End DoDot:2
+28 ;
+29 ;Convert Multiple Values into one Value
+30 IF $DATA(MPARMS)
Begin DoDot:2
+31 SET NAME=""
+32 FOR
SET NAME=$ORDER(MPARMS(NAME))
IF NAME=""
QUIT
Begin DoDot:3
+33 SET VAL=""
SET VALS=""
+34 FOR
SET VAL=$ORDER(MPARMS(NAME,VAL))
IF VAL=""
QUIT
SET VALS=VALS_VAL_", "
+35 SET VALS=$$TKO^BQIUL1(VALS,", ")
+36 SET PARMS(NAME)=VALS
End DoDot:3
End DoDot:2
+37 ;
+38 ;Define Description Format
+39 SET NDESC="My Patients where provider |PROV| specialties are |TYPE|."
+40 ;
+41 ;Assemble Filter
+42 IF $ORDER(^BQICARE(OWNR,1,PLIEN,15,0))
Begin DoDot:2
+43 SET FILTER=$$FILTER^BQIPLDS1(OWNR,PLIEN)
+44 IF $GET(BMXSEC)'=""
QUIT
+45 IF $GET(NDESC)=""
DO FILDES(FILTER,1)
QUIT
+46 IF '$FIND(NDESC,"|")
SET DESC(1,0)=NDESC
DO FILDES(FILTER,2)
QUIT
End DoDot:2
IF $GET(BMXSEC)'=""
QUIT
+47 ;
+48 ;Assemble Generated Description
+49 FOR
IF '$FIND(NDESC,"|")
QUIT
DO PRS
+50 SET DESC(1,0)=$GET(PDESC)
DO FILDES(FILTER,2)
+51 QUIT
End DoDot:1
QUIT
+52 ;
+53 ;Manual Patients
+54 ;
+55 IF TYPE="M"
SET DESC(1,0)="The patients who were selected manually"
QUIT
+56 ;
+57 ;QMAN Template
+58 ;
+59 IF TYPE="Q"
Begin DoDot:1
+60 ;S DESC(1,0)="The patients who were selected by QMAN Template "_$P(^DIBT(SOURCE,0),U,1)
+61 SET DESC(1,0)="Search Template "_$PIECE($GET(^DIBT(SOURCE,0)),U,1)
+62 IF $ORDER(^BQICARE(OWNR,1,PLIEN,15,0))
Begin DoDot:2
+63 ;S FILTER=$$FILTER(OWNR,PLIEN,2,4)
+64 SET FILTER=$$FILTER^BQIPLDS1(OWNR,PLIEN)
+65 IF $GET(BMXSEC)'=""
QUIT
+66 DO FILDES(FILTER,2)
End DoDot:2
IF $GET(BMXSEC)'=""
QUIT
End DoDot:1
QUIT
+67 ;
+68 IF SOURCE=""
QUIT
+69 ;
+70 SET PPIEN=$$PP^BQIDCDF(SOURCE)
IF PPIEN=-1
QUIT
+71 SET NDESC=$$GET1^DIQ(90506,PPIEN,4,"E")
+72 ;
+73 KILL PARMS,MPARMS
+74 ;
+75 ; Get parameters from panel definition
+76 SET N=0
FOR
SET N=$ORDER(^BQICARE(OWNR,1,PLIEN,10,N))
IF 'N
QUIT
Begin DoDot:1
+77 NEW DA,IENS,NAME,DESCEX,VALUE,PPIEN,PTYP
+78 SET DA(2)=OWNR
SET DA(1)=PLIEN
SET DA=N
SET IENS=$$IENS^DILF(.DA)
+79 SET NAME=$$GET1^DIQ(90505.02,IENS,.01,"E")
+80 SET PPIEN=$$PP^BQIDCDF(SOURCE)
+81 IF PPIEN
SET DESCEX=$$GET1^DIQ(90506,PPIEN,5,"I")
+82 SET PTYP=$$PTYP^BQIDCDF(SOURCE,NAME)
+83 IF PTYP="T"
Begin DoDot:2
+84 SET VALUE=$$GET1^DIQ(90505.02,IENS,.03,"E")
+85 SET BQFIL=$$FILN^BQIDCDF(SOURCE,NAME)
IF BQFIL=""
QUIT
+86 SET VALUE=$$GET1^DIQ(BQFIL,VALUE,.01,"E")
End DoDot:2
+87 IF PTYP'="T"
SET VALUE=$$GET1^DIQ(90505.02,IENS,.02,"E")
+88 ;
+89 ;Save unformatted parameter values
+90 SET OPARMS(NAME)=VALUE
+91 ;
+92 IF PTYP="D"
SET VALUE=$$UP^XLFSTR($$FMTE^XLFDT(VALUE,1))
+93 IF PTYP="R"
Begin DoDot:2
+94 SET VALUE=$$DATE^BQIUL1(VALUE)
+95 SET VALUE=$$UP^XLFSTR($$FMTE^XLFDT(VALUE,1))
End DoDot:2
+96 IF VALUE'=""
Begin DoDot:2
+97 IF $GET(DESCEX)'=""
XECUTE DESCEX
+98 SET PARMS(NAME)=VALUE
End DoDot:2
QUIT
+99 IF VALUE=""
Begin DoDot:2
+100 IF '$DATA(^BQICARE(OWNR,1,PLIEN,10,N,1))
QUIT
+101 NEW MN
+102 SET MN=0
FOR
SET MN=$ORDER(^BQICARE(OWNR,1,PLIEN,10,N,1,MN))
IF 'MN
QUIT
Begin DoDot:3
+103 NEW DA,IENS,VALUE
+104 SET DA(3)=OWNR
SET DA(2)=PLIEN
SET DA(1)=N
SET DA=MN
SET IENS=$$IENS^DILF(.DA)
+105 IF PTYP="T"
Begin DoDot:4
+106 SET VALUE=$$GET1^DIQ(90505.21,IENS,.02,"E")
+107 SET BQFIL=$$FILN^BQIDCDF(SOURCE,NAME)
IF BQFIL=""
QUIT
+108 SET VALUE=$$GET1^DIQ(BQFIL,VALUE,.01,"E")
End DoDot:4
+109 IF PTYP'="T"
SET VALUE=$$GET1^DIQ(90505.21,IENS,.01,"E")
+110 IF VALUE'=""
IF $GET(DESCEX)'=""
XECUTE DESCEX
+111 IF VALUE]""
SET MPARMS(NAME,VALUE)=""
End DoDot:3
End DoDot:2
End DoDot:1
+112 ;
+113 ;Special Code to Assemble Primary/Secondary Provider Information into "TYPE" node
+114 IF $DATA(MPARMS("TYPE","PRIM"))
DO PSVST^BQIPLDS1("PRIM",$GET(OPARMS("PVISITS")),$GET(OPARMS("PTMFRAME")),.MPARMS)
+115 IF $DATA(MPARMS("TYPE","PRSC"))
DO PSVST^BQIPLDS1("PRSC",$GET(OPARMS("PSVISITS")),$GET(OPARMS("PSTMFRAM")),.MPARMS)
+116 ;
+117 IF $ORDER(^BQICARE(OWNR,1,PLIEN,15,0))
Begin DoDot:1
+118 SET FILTER=$$FILTER^BQIPLDS1(OWNR,PLIEN)
+119 IF $GET(BMXSEC)'=""
QUIT
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+120 IF $GET(NDESC)=""
DO FILDES(FILTER,1)
QUIT
+121 IF '$FIND(NDESC,"|")
SET DESC(1,0)=NDESC
DO FILDES(FILTER,2)
QUIT
+122 ;
+123 IF $DATA(MPARMS)
Begin DoDot:1
+124 SET NAME=""
+125 FOR
SET NAME=$ORDER(MPARMS(NAME))
IF NAME=""
QUIT
Begin DoDot:2
+126 SET VAL=""
SET VALS=""
+127 FOR
SET VAL=$ORDER(MPARMS(NAME,VAL))
IF VAL=""
QUIT
SET VALS=VALS_VAL_", "
+128 SET VALS=$$TKO^BQIUL1(VALS,", ")
+129 SET PARMS(NAME)=VALS
End DoDot:2
End DoDot:1
+130 ;
+131 SET ODESC=NDESC
+132 FOR
IF '$FIND(NDESC,"|")
QUIT
DO PRS
+133 SET DESC(1,0)=PDESC
DO FILDES(FILTER,2)
+134 QUIT
+135 ;
PRS ; Parse description
+1 SET NDESC=$PIECE(NDESC,"|",1)_$GET(PARMS($PIECE(NDESC,"|",2)))_$PIECE(NDESC,"|",3,99)
+2 SET PDESC=NDESC
+3 QUIT
+4 ;
FILDES(FILTER,ENT) ;EP - Load filter description in DESC()
+1 NEW PC
+2 IF FILTER'=""
Begin DoDot:1
+3 ;S FILTER="Panel filtered by: "_FILTER
+4 IF '$DATA(ENT)
SET ENT=$ORDER(DESC(""),-1)+1
+5 FOR I=1:1:$LENGTH(FILTER,"; ")
SET PC=$PIECE(FILTER,"; ",I)
IF PC'=""
SET DESC(ENT,0)=PC_"; "
SET ENT=ENT+1
+6 SET ENT=ENT-1
+7 IF $DATA(DESC(ENT,0))
SET DESC(ENT,0)=$$TKO^BQIUL1(DESC(ENT,0),"; ")
End DoDot:1
+8 QUIT
+9 ;
MEN(OWNR,PREF) ;EP -- Format my patients preferences generated description
+1 ;
+2 ;Description
+3 ; The my patients preferences description is based on the values of the parameters
+4 ;
+5 NEW DA,IENS,SOURCE,PPIEN,DESC,ODESC,NDESC,PARMS,MPARMS,N,NAME,PTYP,VALUE
+6 NEW BQFIL,VAL,VALS
+7 SET DESC=""
SET NDESC=""
+8 SET DA(1)=OWNR
SET DA=PREF
SET IENS=$$IENS^DILF(.DA)
+9 SET SOURCE=$$GET1^DIQ(90505.07,IENS,.01,"E")
+10 ;
+11 SET PPIEN=$$PP^BQIDCDF(SOURCE)
IF PPIEN=-1
QUIT ""
+12 SET DESC=$$GET1^DIQ(90506,PPIEN,4,"E")
+13 IF DESC=""
QUIT ""
+14 ;
+15 ; Get parameters from my patient definition
+16 SET N=0
FOR
SET N=$ORDER(^BQICARE(OWNR,7,PREF,10,N))
IF 'N
QUIT
Begin DoDot:1
+17 NEW DA,IENS,NAME,VALUE
+18 SET DA(2)=OWNR
SET DA(1)=PREF
SET DA=N
SET IENS=$$IENS^DILF(.DA)
+19 SET NAME=$$GET1^DIQ(90505.08,IENS,.01,"E")
+20 SET PTYP=$$PTYP^BQIDCDF(SOURCE,NAME)
+21 IF PTYP="T"
Begin DoDot:2
+22 SET VALUE=$$GET1^DIQ(90505.08,IENS,.03,"E")
+23 SET BQFIL=$$FILN^BQIDCDF(SOURCE,NAME)
IF BQFIL=""
QUIT
+24 SET VALUE=$$GET1^DIQ(BQFIL,VALUE,.01,"E")
End DoDot:2
+25 IF PTYP'="T"
SET VALUE=$$GET1^DIQ(90505.08,IENS,.02,"E")
+26 IF PTYP="D"
SET VALUE=$$UP^XLFSTR($$FMTE^XLFDT(VALUE,1))
+27 IF PTYP="R"
Begin DoDot:2
+28 SET VALUE=$$DATE^BQIUL1(VALUE)
+29 SET VALUE=$$UP^XLFSTR($$FMTE^XLFDT(VALUE,1))
End DoDot:2
+30 IF NAME="SPEC"
IF VALUE'=""
Begin DoDot:2
+31 NEW SPECNM
+32 ;Mnemonic
SET SPECNM=$$GET1^DIQ(90360.3,VALUE,.01,"I")
+33 SET VALUE=SPECNM
End DoDot:2
IF VALUE=""
QUIT
+34 IF VALUE'=""
SET PARMS(NAME)=VALUE
QUIT
+35 IF VALUE=""
Begin DoDot:2
+36 IF '$DATA(^BQICARE(OWNR,7,PREF,10,N,1))
QUIT
+37 NEW MN
+38 SET MN=0
FOR
SET MN=$ORDER(^BQICARE(OWNR,7,PREF,10,N,1,MN))
IF 'MN
QUIT
Begin DoDot:3
+39 NEW DA,IENS,VALUE
+40 SET DA(3)=OWNR
SET DA(2)=PREF
SET DA(1)=N
SET DA=MN
SET IENS=$$IENS^DILF(.DA)
+41 IF PTYP="T"
Begin DoDot:4
+42 SET VALUE=$$GET1^DIQ(90505.81,IENS,.02,"E")
+43 SET BQFIL=$$FILN^BQIDCDF(SOURCE,NAME)
IF BQFIL=""
QUIT
+44 SET VALUE=$$GET1^DIQ(BQFIL,VALUE,.01,"E")
End DoDot:4
+45 IF PTYP'="T"
SET VALUE=$$GET1^DIQ(90505.81,IENS,.01,"E")
+46 IF NAME="SPEC"
IF VALUE'=""
Begin DoDot:4
+47 NEW SPECNM
+48 ;Mnemonic
SET SPECNM=$$GET1^DIQ(90360.3,VALUE,.01,"I")
+49 SET VALUE=SPECNM
End DoDot:4
IF VALUE=""
QUIT
+50 SET MPARMS(NAME,VALUE)=""
End DoDot:3
End DoDot:2
End DoDot:1
+51 ;
+52 IF '$FIND(DESC,"|")
QUIT ""
+53 IF $DATA(PARMS)<10
QUIT ""
+54 ;
+55 IF $DATA(MPARMS)
Begin DoDot:1
+56 SET NAME=""
+57 FOR
SET NAME=$ORDER(MPARMS(NAME))
IF NAME=""
QUIT
Begin DoDot:2
+58 SET VAL=""
SET VALS=""
+59 FOR
SET VAL=$ORDER(MPARMS(NAME,VAL))
IF VAL=""
QUIT
SET VALS=VALS_VAL_", "
+60 SET VALS=$$TKO^BQIUL1(VALS,", ")
+61 SET PARMS(NAME)=VALS
End DoDot:2
End DoDot:1
+62 ;
+63 SET ODESC=DESC
SET NDESC=DESC
+64 FOR
IF '$FIND(NDESC,"|")
QUIT
DO PRS
+65 QUIT PDESC
