BQIPLPM ;PRXM/HC/ALA-Get Panel Parameters ; 13 Nov 2008 3:07 PM
;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66
;
Q
;
RET(DATA,OWNR,PLIEN) ; EP -- BQI GET PANEL PARAMS
;
;Description - Retrieves the panel parameters for a specific panel
;
;Input
; OWNR - Owner of the panel internal entry number
; PLIEN - Panel internal entry number
;Output
; DATA - name of global (passed by reference) in which the data
; is stored
;Assumes
; DUZ - User who signed onto iCare
;
NEW UID,II,X
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPLPM",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPLPM D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S @DATA@(II)="T03200PARMS"_$C(30)
;
NEW DA,IENS,EXEC,SOURCE,TYPE,PPIEN,PTYP,N,NN,PARMS,MPARMS,MMAP,MPFL,MPNAME
S DA(1)=OWNR,DA=PLIEN,IENS=$$IENS^DILF(.DA),EXEC=""
S SOURCE=$$GET1^DIQ(90505.01,IENS,.11,"E")
S TYPE=$$GET1^DIQ(90505.01,IENS,.03,"I")
;
I TYPE'="P" G DONE
;
; Find predefined panel
I SOURCE="" G DONE
S PPIEN=$$PP^BQIDCDF(SOURCE) I PPIEN=-1 S BMXSEC="Pre-defined panel type "_SOURCE_" was not found" Q
;
S N=0,PARMS="",MPARMS=""
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 VALUE=$$GET1^DIQ(90505.02,IENS,.03,"E")
. I VALUE="" S VALUE=$$GET1^DIQ(90505.02,IENS,.02,"E")
. S PTYP=$$PTYP^BQIDCDF(SOURCE,NAME)
. S MPFL=$$MPF^BQIDCDF(SOURCE,NAME)
. I MPFL D Q
.. S MPNAME=$$MPN^BQIDCDF(SOURCE,NAME)
.. I $G(VALUE)'="" D MLMP Q
.. ;
.. S NN=0
.. F S NN=$O(^BQICARE(OWNR,1,PLIEN,10,N,1,NN)) Q:'NN D
... NEW DA,IENS
... S DA(3)=OWNR,DA(2)=PLIEN,DA(1)=N,DA=NN,IENS=$$IENS^DILF(.DA)
... S VALUE=$$GET1^DIQ(90505.21,IENS,.02,"E")
... I VALUE="" S VALUE=$$GET1^DIQ(90505.21,IENS,.01,"E")
... I PTYP="D" S VALUE=$$FMTE^BQIUL1(VALUE)
... D MLMP
. I 'MPFL S MPARMS=NAME_"="
. ;
. ;S MPARMS=NAME_"="
. I PTYP="D" S VALUE=$$FMTE^BQIUL1(VALUE)
. I '$D(^BQICARE(OWNR,1,PLIEN,10,N,1)) S MPARMS=MPARMS_VALUE
. I $D(^BQICARE(OWNR,1,PLIEN,10,N,1)) D
.. S NN=0
.. F S NN=$O(^BQICARE(OWNR,1,PLIEN,10,N,1,NN)) Q:'NN D
... NEW DA,IENS
... S DA(3)=OWNR,DA(2)=PLIEN,DA(1)=N,DA=NN,IENS=$$IENS^DILF(.DA)
... S VALUE=$$GET1^DIQ(90505.21,IENS,.02,"E")
... I VALUE="" S VALUE=$$GET1^DIQ(90505.21,IENS,.01,"E")
... I PTYP="D" S VALUE=$$FMTE^BQIUL1(VALUE)
... S MPARMS=MPARMS_VALUE_$C(29)
.. S MPARMS=$$TKO^BQIUL1(MPARMS,$C(29))
. S PARMS=PARMS_MPARMS_$C(28)
; Check on mapping values
I $D(MMAP)>0 D
. S PNAME=""
. F S PNAME=$O(MMAP(PNAME)) Q:PNAME="" D
.. S PRIEN=$O(^BQI(90506,PPIEN,3,"B",PNAME,"")) I PRIEN="" Q
.. S VALUE=MMAP(PNAME)
.. S VLIEN=$O(^BQI(90506,PPIEN,3,PRIEN,3,"AC",VALUE,"")) I VLIEN="" Q
.. S PARMS=PARMS_PNAME_"="_$P(^BQI(90506,PPIEN,3,PRIEN,3,VLIEN,0),U,1)_$C(28)
S II=II+1
S PARMS=$$TKO^BQIUL1(PARMS,$C(28))
S @DATA@(II)=PARMS_$C(30)
;
DONE ;
S II=II+1,@DATA@(II)=$C(31)
Q
;
MLMP ; Map the values
I '$D(MMAP(MPNAME)) S MMAP(MPNAME)=NAME_"="_VALUE Q
;S $P(MMAP(MPNAME),"~",2)=NAME_"="_VALUE
S MMAP(MPNAME)=MMAP(MPNAME)_"~"_NAME_"="_VALUE
D CKMP(MPNAME)
I $A($E(PARMS,$L(PARMS),$L(PARMS)))'=28 S PARMS=PARMS_$C(28)
Q
;
CKMP(PNAME) ;EP - Check mapping
S PRIEN=$O(^BQI(90506,PPIEN,3,"B",PNAME,"")) I PRIEN="" Q
S VALUE=MMAP(PNAME)
S VLIEN=$O(^BQI(90506,PPIEN,3,PRIEN,3,"AC",VALUE,"")) I VLIEN="" Q
I PARMS[VALUE Q
I PARMS[PNAME D Q
. S PARMS=$$TKO^BQIUL1(PARMS,$C(28))
. S PARMS=PARMS_$C(29)_$P(^BQI(90506,PPIEN,3,PRIEN,3,VLIEN,0),U,1)
. K MMAP(PNAME)
S PARMS=PARMS_PNAME_"="_$P(^BQI(90506,PPIEN,3,PRIEN,3,VLIEN,0),U,1)
K MMAP(PNAME)
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)
Q
;
UPD(DATA,OWNR,PLIEN,PARMS) ; EP -- BQI SET PANEL PARAMS
;
;Description
; Update or set the panel parameters
;Input
; OWNR - Owner of panel IEN
; PLIEN - Panel internal entry number
; PARMS - Parameters (if NULL, deletes ALL)
; if PARMS contain a $C(29), then that is
; a multiple value parameter
;
NEW UID,II,BN,RESULT
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPLPM",UID))
K @DATA
;
; Check if share and has write access
I '$$CKSHR^BQIPLSH(OWNR,PLIEN) S BMXSEC="You do not have write access" Q
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPLPM D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S PARMS=$G(PARMS,"")
S @DATA@(II)="I00010RESULT"_$C(30)
S RESULT=1 ; Initialize value
;
D DEL(.OWNR,.PLIEN)
;
NEW DA,IENS,EXEC,SOURCE,TYPE,PPIEN,PTYP,BQ,BQIUPD,BQVAL,BI,NVAL
NEW PDATA,MVAL,PDA,QFL,BQII,ERROR,PQ,BN,LIST
S DA(1)=OWNR,DA=PLIEN,IENS=$$IENS^DILF(.DA),EXEC=""
S SOURCE=$$GET1^DIQ(90505.01,IENS,.11,"E")
S TYPE=$$GET1^DIQ(90505.01,IENS,.03,"I")
;
I SOURCE="" D G DONE
. D DSC
. S II=II+1,@DATA@(II)="1"_$C(30)
;
I TYPE'="P" D G DONE
. D DSC
. S II=II+1,@DATA@(II)="1"_$C(30)
;
; Find predefined panel
S PPIEN=$$PP^BQIDCDF(SOURCE) I PPIEN=-1 S BMXSEC="Pre-defined panel type "_SOURCE_" was not found" Q
;
S PARMS=$G(PARMS,"")
I PARMS="" D
. S LIST="",BN=""
. F S BN=$O(PARMS(BN)) Q:BN="" S LIST=LIST_PARMS(BN)
. K PARMS
. S PARMS=LIST
. K LIST
;
S QFL=0
F BQ=1:1:$L(PARMS,$C(28)) D G DONE:QFL
. S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
. S NAME=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99)
. S PTYP=$$PTYP^BQIDCDF(SOURCE,NAME)
. I PTYP="C" S PQ=0 D Q:PQ
.. NEW PRIEN,VLIEN,VDATA,BJ,CPARM,CNAME,CVAL
.. S PRIEN=$O(^BQI(90506,PPIEN,3,"B",NAME,"")) I PRIEN="" Q
.. I VALUE[$C(29) D
... F BI=1:1:$L(VALUE,$C(29)) S BQVAL=$P(VALUE,$C(29),BI) D PARS(BQVAL)
.. I VALUE'[$C(29) D PARS(VALUE)
.. S II=II+1,@DATA@(II)=RESULT_$C(30),PQ=1
. ;
. ; Create a new parameter record
. S (DA,PDA)=$$ANP(OWNR,PLIEN,NAME)
. I DA=-1 S II=II+1,@DATA@(II)="-1"_$C(30),QFL=1 Q
. ;
. ; Update the parameter with the values
. S RESULT=$$UPP(OWNR,PLIEN,PDA,VALUE,PTYP)
. I RESULT=-1 S II=II+1,@DATA@(II)="-1"_$C(30),QFL=1 Q
;
S II=II+1,@DATA@(II)=RESULT_$C(30)
S II=II+1,@DATA@(II)=$C(31)
;
DSC ; Generate special panel description
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
Q
;
DEL(OWNR,PLIEN) ;EP - Remove the previous parameters
NEW DA,IENS,DIK
S DA(2)=OWNR,DA(1)=PLIEN,DA=0
S DIK="^BQICARE("_DA(2)_",1,"_DA(1)_",10,"
F S DA=$O(^BQICARE(OWNR,1,PLIEN,10,DA)) Q:'DA D ^DIK
Q
;
ANP(OWNR,PLIEN,NAME) ; EP - Add new parameter
NEW DA,IENS,DIC,DLAYGO
S DA(2)=OWNR,DA(1)=PLIEN,X=NAME
S DLAYGO=90505.02,DIC(0)="L",DIC("P")=DLAYGO
S DIC="^BQICARE("_DA(2)_",1,"_DA(1)_",10,"
I '$D(^BQICARE(DA(2),1,DA(1),10,0)) S ^BQICARE(DA(2),1,DA(1),10,0)="^90505.02^^"
K DO,DD D FILE^DICN
Q +Y
;
UPP(OWNR,PLIEN,PDA,VALUE,PTYP) ;EP - Update values for a parameter
NEW DA,IENS,RESULT
S RESULT=1
S DA(2)=OWNR,DA(1)=PLIEN,DA=PDA
S IENS=$$IENS^DILF(.DA)
I VALUE'[$C(29) D
. I PTYP="D" S VALUE=$$DATE^BQIUL1(VALUE)
. I PTYP="T" S BQIUPD(90505.02,IENS,.03)=VALUE
. I PTYP'="T" S BQIUPD(90505.02,IENS,.02)=VALUE
. D FILE^DIE("","BQIUPD","ERROR")
. K BQIUPD
. I $D(ERROR) S RESULT=-1
;
I VALUE[$C(29) D
. I '$D(^BQICARE(DA(2),1,DA(1),10,DA,1,0)) S ^BQICARE(DA(2),1,DA(1),10,DA,1,0)="^90505.21^^"
. F BQII=1:1:$L(VALUE,$C(29)) D
.. S MVAL=$P(VALUE,$C(29),BQII)
.. NEW DA,IENS
.. S DA(3)=OWNR,DA(2)=PLIEN,DA(1)=PDA,X=MVAL
.. S DLAYGO=90505.21,DIC(0)="L",DIC("P")=DLAYGO
.. S DIC="^BQICARE("_DA(3)_",1,"_DA(2)_",10,"_DA(1)_",1,"
.. K DO,DD D FILE^DICN
.. I +Y=-1 S RESULT=-1
.. I PTYP="D" S MVAL=$$DATE^BQIUL1(MVAL)
.. S DA=+Y,IENS=$$IENS^DILF(.DA)
.. I PTYP="T" S BQIUPD(90505.21,IENS,.02)=MVAL
.. I PTYP'="T" S BQIUPD(90505.21,IENS,.01)=MVAL
.. D FILE^DIE("","BQIUPD","ERROR")
.. K BQIUPD
.. I $D(ERROR) S RESULT=-1
Q RESULT
;
PARS(NVAL) ;EP
N PRDATA,PRMN
S VLIEN=$O(^BQI(90506,PPIEN,3,PRIEN,3,"B",NVAL,"")) I VLIEN="" Q
S VDATA=$P(^BQI(90506,PPIEN,3,PRIEN,3,VLIEN,0),U,2)
S PVAL="",PRMN=$L(VDATA,"~")
F BJ=1:1 S CPARM=$P(VDATA,"~",BJ) Q:CPARM="" D
. S CNAME=$P(CPARM,"=",1),CVAL=$P(CPARM,"=",2)
. S PRDATA=$P(VDATA,"~",BJ+1)
. I $P(PRDATA,"=",1)'=CNAME,PVAL="" D Q
.. S (DA,PDA)=$$ANP(OWNR,PLIEN,CNAME)
.. I DA=-1 S II=II+1,@DATA@(II)="-1"_$C(30) Q
.. S RESULT=$$UPP(OWNR,PLIEN,PDA,CVAL,PTYP)
.. I RESULT=-1 S II=II+1,@DATA@(II)=RESULT_$C(30) Q
. S PVAL=PVAL_CVAL_$C(29)
I PVAL'="" D
. S (DA,PDA)=$$ANP(OWNR,PLIEN,CNAME)
. I DA=-1 S II=II+1,@DATA@(II)="-1"_$C(30) Q
. S CVAL=$$TKO^BQIUL1(PVAL,$C(29))
. S RESULT=$$UPP(OWNR,PLIEN,PDA,CVAL,PTYP)
. I RESULT=-1 S II=II+1,@DATA@(II)=RESULT_$C(30) Q
Q
;
CRMP ;
S (DA,PDA)=$$ANP(OWNR,PLIEN,CNAME)
I DA=-1 S II=II+1,@DATA@(II)="-1"_$C(30),QFL=1 Q
S CVAL=$$TKO^BQIUL1(PVAL,$C(29))
S RESULT=$$UPP(OWNR,PLIEN,PDA,CVAL,PTYP)
I RESULT=-1 S II=II+1,@DATA@(II)=RESULT_$C(30),QFL=1 Q
Q
BQIPLPM ;PRXM/HC/ALA-Get Panel Parameters ; 13 Nov 2008 3:07 PM
+1 ;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66
+2 ;
+3 QUIT
+4 ;
RET(DATA,OWNR,PLIEN) ; EP -- BQI GET PANEL PARAMS
+1 ;
+2 ;Description - Retrieves the panel parameters for a specific panel
+3 ;
+4 ;Input
+5 ; OWNR - Owner of the panel internal entry number
+6 ; PLIEN - Panel internal entry number
+7 ;Output
+8 ; DATA - name of global (passed by reference) in which the data
+9 ; is stored
+10 ;Assumes
+11 ; DUZ - User who signed onto iCare
+12 ;
+13 NEW UID,II,X
+14 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+15 SET DATA=$NAME(^TMP("BQIPLPM",UID))
+16 KILL @DATA
+17 ;
+18 SET II=0
+19 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPLPM D UNWIND^%ZTER"
+20 ;
+21 SET @DATA@(II)="T03200PARMS"_$CHAR(30)
+22 ;
+23 NEW DA,IENS,EXEC,SOURCE,TYPE,PPIEN,PTYP,N,NN,PARMS,MPARMS,MMAP,MPFL,MPNAME
+24 SET DA(1)=OWNR
SET DA=PLIEN
SET IENS=$$IENS^DILF(.DA)
SET EXEC=""
+25 SET SOURCE=$$GET1^DIQ(90505.01,IENS,.11,"E")
+26 SET TYPE=$$GET1^DIQ(90505.01,IENS,.03,"I")
+27 ;
+28 IF TYPE'="P"
GOTO DONE
+29 ;
+30 ; Find predefined panel
+31 IF SOURCE=""
GOTO DONE
+32 SET PPIEN=$$PP^BQIDCDF(SOURCE)
IF PPIEN=-1
SET BMXSEC="Pre-defined panel type "_SOURCE_" was not found"
QUIT
+33 ;
+34 SET N=0
SET PARMS=""
SET MPARMS=""
+35 FOR
SET N=$ORDER(^BQICARE(OWNR,1,PLIEN,10,N))
IF 'N
QUIT
Begin DoDot:1
+36 NEW DA,IENS,NAME,VALUE
+37 SET DA(2)=OWNR
SET DA(1)=PLIEN
SET DA=N
SET IENS=$$IENS^DILF(.DA)
+38 SET NAME=$$GET1^DIQ(90505.02,IENS,.01,"E")
+39 SET VALUE=$$GET1^DIQ(90505.02,IENS,.03,"E")
+40 IF VALUE=""
SET VALUE=$$GET1^DIQ(90505.02,IENS,.02,"E")
+41 SET PTYP=$$PTYP^BQIDCDF(SOURCE,NAME)
+42 SET MPFL=$$MPF^BQIDCDF(SOURCE,NAME)
+43 IF MPFL
Begin DoDot:2
+44 SET MPNAME=$$MPN^BQIDCDF(SOURCE,NAME)
+45 IF $GET(VALUE)'=""
DO MLMP
QUIT
+46 ;
+47 SET NN=0
+48 FOR
SET NN=$ORDER(^BQICARE(OWNR,1,PLIEN,10,N,1,NN))
IF 'NN
QUIT
Begin DoDot:3
+49 NEW DA,IENS
+50 SET DA(3)=OWNR
SET DA(2)=PLIEN
SET DA(1)=N
SET DA=NN
SET IENS=$$IENS^DILF(.DA)
+51 SET VALUE=$$GET1^DIQ(90505.21,IENS,.02,"E")
+52 IF VALUE=""
SET VALUE=$$GET1^DIQ(90505.21,IENS,.01,"E")
+53 IF PTYP="D"
SET VALUE=$$FMTE^BQIUL1(VALUE)
+54 DO MLMP
End DoDot:3
End DoDot:2
QUIT
+55 IF 'MPFL
SET MPARMS=NAME_"="
+56 ;
+57 ;S MPARMS=NAME_"="
+58 IF PTYP="D"
SET VALUE=$$FMTE^BQIUL1(VALUE)
+59 IF '$DATA(^BQICARE(OWNR,1,PLIEN,10,N,1))
SET MPARMS=MPARMS_VALUE
+60 IF $DATA(^BQICARE(OWNR,1,PLIEN,10,N,1))
Begin DoDot:2
+61 SET NN=0
+62 FOR
SET NN=$ORDER(^BQICARE(OWNR,1,PLIEN,10,N,1,NN))
IF 'NN
QUIT
Begin DoDot:3
+63 NEW DA,IENS
+64 SET DA(3)=OWNR
SET DA(2)=PLIEN
SET DA(1)=N
SET DA=NN
SET IENS=$$IENS^DILF(.DA)
+65 SET VALUE=$$GET1^DIQ(90505.21,IENS,.02,"E")
+66 IF VALUE=""
SET VALUE=$$GET1^DIQ(90505.21,IENS,.01,"E")
+67 IF PTYP="D"
SET VALUE=$$FMTE^BQIUL1(VALUE)
+68 SET MPARMS=MPARMS_VALUE_$CHAR(29)
End DoDot:3
+69 SET MPARMS=$$TKO^BQIUL1(MPARMS,$CHAR(29))
End DoDot:2
+70 SET PARMS=PARMS_MPARMS_$CHAR(28)
End DoDot:1
+71 ; Check on mapping values
+72 IF $DATA(MMAP)>0
Begin DoDot:1
+73 SET PNAME=""
+74 FOR
SET PNAME=$ORDER(MMAP(PNAME))
IF PNAME=""
QUIT
Begin DoDot:2
+75 SET PRIEN=$ORDER(^BQI(90506,PPIEN,3,"B",PNAME,""))
IF PRIEN=""
QUIT
+76 SET VALUE=MMAP(PNAME)
+77 SET VLIEN=$ORDER(^BQI(90506,PPIEN,3,PRIEN,3,"AC",VALUE,""))
IF VLIEN=""
QUIT
+78 SET PARMS=PARMS_PNAME_"="_$PIECE(^BQI(90506,PPIEN,3,PRIEN,3,VLIEN,0),U,1)_$CHAR(28)
End DoDot:2
End DoDot:1
+79 SET II=II+1
+80 SET PARMS=$$TKO^BQIUL1(PARMS,$CHAR(28))
+81 SET @DATA@(II)=PARMS_$CHAR(30)
+82 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
MLMP ; Map the values
+1 IF '$DATA(MMAP(MPNAME))
SET MMAP(MPNAME)=NAME_"="_VALUE
QUIT
+2 ;S $P(MMAP(MPNAME),"~",2)=NAME_"="_VALUE
+3 SET MMAP(MPNAME)=MMAP(MPNAME)_"~"_NAME_"="_VALUE
+4 DO CKMP(MPNAME)
+5 IF $ASCII($EXTRACT(PARMS,$LENGTH(PARMS),$LENGTH(PARMS)))'=28
SET PARMS=PARMS_$CHAR(28)
+6 QUIT
+7 ;
CKMP(PNAME) ;EP - Check mapping
+1 SET PRIEN=$ORDER(^BQI(90506,PPIEN,3,"B",PNAME,""))
IF PRIEN=""
QUIT
+2 SET VALUE=MMAP(PNAME)
+3 SET VLIEN=$ORDER(^BQI(90506,PPIEN,3,PRIEN,3,"AC",VALUE,""))
IF VLIEN=""
QUIT
+4 IF PARMS[VALUE
QUIT
+5 IF PARMS[PNAME
Begin DoDot:1
+6 SET PARMS=$$TKO^BQIUL1(PARMS,$CHAR(28))
+7 SET PARMS=PARMS_$CHAR(29)_$PIECE(^BQI(90506,PPIEN,3,PRIEN,3,VLIEN,0),U,1)
+8 KILL MMAP(PNAME)
End DoDot:1
QUIT
+9 SET PARMS=PARMS_PNAME_"="_$PIECE(^BQI(90506,PPIEN,3,PRIEN,3,VLIEN,0),U,1)
+10 KILL MMAP(PNAME)
+11 QUIT
+12 ;
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 QUIT
+7 ;
UPD(DATA,OWNR,PLIEN,PARMS) ; EP -- BQI SET PANEL PARAMS
+1 ;
+2 ;Description
+3 ; Update or set the panel parameters
+4 ;Input
+5 ; OWNR - Owner of panel IEN
+6 ; PLIEN - Panel internal entry number
+7 ; PARMS - Parameters (if NULL, deletes ALL)
+8 ; if PARMS contain a $C(29), then that is
+9 ; a multiple value parameter
+10 ;
+11 NEW UID,II,BN,RESULT
+12 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+13 SET DATA=$NAME(^TMP("BQIPLPM",UID))
+14 KILL @DATA
+15 ;
+16 ; Check if share and has write access
+17 IF '$$CKSHR^BQIPLSH(OWNR,PLIEN)
SET BMXSEC="You do not have write access"
QUIT
+18 ;
+19 SET II=0
+20 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPLPM D UNWIND^%ZTER"
+21 ;
+22 SET PARMS=$GET(PARMS,"")
+23 SET @DATA@(II)="I00010RESULT"_$CHAR(30)
+24 ; Initialize value
SET RESULT=1
+25 ;
+26 DO DEL(.OWNR,.PLIEN)
+27 ;
+28 NEW DA,IENS,EXEC,SOURCE,TYPE,PPIEN,PTYP,BQ,BQIUPD,BQVAL,BI,NVAL
+29 NEW PDATA,MVAL,PDA,QFL,BQII,ERROR,PQ,BN,LIST
+30 SET DA(1)=OWNR
SET DA=PLIEN
SET IENS=$$IENS^DILF(.DA)
SET EXEC=""
+31 SET SOURCE=$$GET1^DIQ(90505.01,IENS,.11,"E")
+32 SET TYPE=$$GET1^DIQ(90505.01,IENS,.03,"I")
+33 ;
+34 IF SOURCE=""
Begin DoDot:1
+35 DO DSC
+36 SET II=II+1
SET @DATA@(II)="1"_$CHAR(30)
End DoDot:1
GOTO DONE
+37 ;
+38 IF TYPE'="P"
Begin DoDot:1
+39 DO DSC
+40 SET II=II+1
SET @DATA@(II)="1"_$CHAR(30)
End DoDot:1
GOTO DONE
+41 ;
+42 ; Find predefined panel
+43 SET PPIEN=$$PP^BQIDCDF(SOURCE)
IF PPIEN=-1
SET BMXSEC="Pre-defined panel type "_SOURCE_" was not found"
QUIT
+44 ;
+45 SET PARMS=$GET(PARMS,"")
+46 IF PARMS=""
Begin DoDot:1
+47 SET LIST=""
SET BN=""
+48 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+49 KILL PARMS
+50 SET PARMS=LIST
+51 KILL LIST
End DoDot:1
+52 ;
+53 SET QFL=0
+54 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+55 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+56 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+57 SET PTYP=$$PTYP^BQIDCDF(SOURCE,NAME)
+58 IF PTYP="C"
SET PQ=0
Begin DoDot:2
+59 NEW PRIEN,VLIEN,VDATA,BJ,CPARM,CNAME,CVAL
+60 SET PRIEN=$ORDER(^BQI(90506,PPIEN,3,"B",NAME,""))
IF PRIEN=""
QUIT
+61 IF VALUE[$CHAR(29)
Begin DoDot:3
+62 FOR BI=1:1:$LENGTH(VALUE,$CHAR(29))
SET BQVAL=$PIECE(VALUE,$CHAR(29),BI)
DO PARS(BQVAL)
End DoDot:3
+63 IF VALUE'[$CHAR(29)
DO PARS(VALUE)
+64 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
SET PQ=1
End DoDot:2
IF PQ
QUIT
+65 ;
+66 ; Create a new parameter record
+67 SET (DA,PDA)=$$ANP(OWNR,PLIEN,NAME)
+68 IF DA=-1
SET II=II+1
SET @DATA@(II)="-1"_$CHAR(30)
SET QFL=1
QUIT
+69 ;
+70 ; Update the parameter with the values
+71 SET RESULT=$$UPP(OWNR,PLIEN,PDA,VALUE,PTYP)
+72 IF RESULT=-1
SET II=II+1
SET @DATA@(II)="-1"_$CHAR(30)
SET QFL=1
QUIT
End DoDot:1
IF QFL
GOTO DONE
+73 ;
+74 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+75 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+76 ;
DSC ; Generate special panel description
+1 NEW DA,IENS
+2 SET DA(1)=OWNR
SET DA=PLIEN
SET IENS=$$IENS^DILF(.DA)
+3 KILL DESC
+4 DO DESC^BQIPDSCM(OWNR,PLIEN,.DESC)
+5 ;D PEN^BQIPLDSC(OWNR,PLIEN,.DESC)
+6 DO WP^DIE(90505.01,IENS,5,"","DESC")
+7 KILL DESC
+8 QUIT
+9 ;
DEL(OWNR,PLIEN) ;EP - Remove the previous parameters
+1 NEW DA,IENS,DIK
+2 SET DA(2)=OWNR
SET DA(1)=PLIEN
SET DA=0
+3 SET DIK="^BQICARE("_DA(2)_",1,"_DA(1)_",10,"
+4 FOR
SET DA=$ORDER(^BQICARE(OWNR,1,PLIEN,10,DA))
IF 'DA
QUIT
DO ^DIK
+5 QUIT
+6 ;
ANP(OWNR,PLIEN,NAME) ; EP - Add new parameter
+1 NEW DA,IENS,DIC,DLAYGO
+2 SET DA(2)=OWNR
SET DA(1)=PLIEN
SET X=NAME
+3 SET DLAYGO=90505.02
SET DIC(0)="L"
SET DIC("P")=DLAYGO
+4 SET DIC="^BQICARE("_DA(2)_",1,"_DA(1)_",10,"
+5 IF '$DATA(^BQICARE(DA(2),1,DA(1),10,0))
SET ^BQICARE(DA(2),1,DA(1),10,0)="^90505.02^^"
+6 KILL DO,DD
DO FILE^DICN
+7 QUIT +Y
+8 ;
UPP(OWNR,PLIEN,PDA,VALUE,PTYP) ;EP - Update values for a parameter
+1 NEW DA,IENS,RESULT
+2 SET RESULT=1
+3 SET DA(2)=OWNR
SET DA(1)=PLIEN
SET DA=PDA
+4 SET IENS=$$IENS^DILF(.DA)
+5 IF VALUE'[$CHAR(29)
Begin DoDot:1
+6 IF PTYP="D"
SET VALUE=$$DATE^BQIUL1(VALUE)
+7 IF PTYP="T"
SET BQIUPD(90505.02,IENS,.03)=VALUE
+8 IF PTYP'="T"
SET BQIUPD(90505.02,IENS,.02)=VALUE
+9 DO FILE^DIE("","BQIUPD","ERROR")
+10 KILL BQIUPD
+11 IF $DATA(ERROR)
SET RESULT=-1
End DoDot:1
+12 ;
+13 IF VALUE[$CHAR(29)
Begin DoDot:1
+14 IF '$DATA(^BQICARE(DA(2),1,DA(1),10,DA,1,0))
SET ^BQICARE(DA(2),1,DA(1),10,DA,1,0)="^90505.21^^"
+15 FOR BQII=1:1:$LENGTH(VALUE,$CHAR(29))
Begin DoDot:2
+16 SET MVAL=$PIECE(VALUE,$CHAR(29),BQII)
+17 NEW DA,IENS
+18 SET DA(3)=OWNR
SET DA(2)=PLIEN
SET DA(1)=PDA
SET X=MVAL
+19 SET DLAYGO=90505.21
SET DIC(0)="L"
SET DIC("P")=DLAYGO
+20 SET DIC="^BQICARE("_DA(3)_",1,"_DA(2)_",10,"_DA(1)_",1,"
+21 KILL DO,DD
DO FILE^DICN
+22 IF +Y=-1
SET RESULT=-1
+23 IF PTYP="D"
SET MVAL=$$DATE^BQIUL1(MVAL)
+24 SET DA=+Y
SET IENS=$$IENS^DILF(.DA)
+25 IF PTYP="T"
SET BQIUPD(90505.21,IENS,.02)=MVAL
+26 IF PTYP'="T"
SET BQIUPD(90505.21,IENS,.01)=MVAL
+27 DO FILE^DIE("","BQIUPD","ERROR")
+28 KILL BQIUPD
+29 IF $DATA(ERROR)
SET RESULT=-1
End DoDot:2
End DoDot:1
+30 QUIT RESULT
+31 ;
PARS(NVAL) ;EP
+1 NEW PRDATA,PRMN
+2 SET VLIEN=$ORDER(^BQI(90506,PPIEN,3,PRIEN,3,"B",NVAL,""))
IF VLIEN=""
QUIT
+3 SET VDATA=$PIECE(^BQI(90506,PPIEN,3,PRIEN,3,VLIEN,0),U,2)
+4 SET PVAL=""
SET PRMN=$LENGTH(VDATA,"~")
+5 FOR BJ=1:1
SET CPARM=$PIECE(VDATA,"~",BJ)
IF CPARM=""
QUIT
Begin DoDot:1
+6 SET CNAME=$PIECE(CPARM,"=",1)
SET CVAL=$PIECE(CPARM,"=",2)
+7 SET PRDATA=$PIECE(VDATA,"~",BJ+1)
+8 IF $PIECE(PRDATA,"=",1)'=CNAME
IF PVAL=""
Begin DoDot:2
+9 SET (DA,PDA)=$$ANP(OWNR,PLIEN,CNAME)
+10 IF DA=-1
SET II=II+1
SET @DATA@(II)="-1"_$CHAR(30)
QUIT
+11 SET RESULT=$$UPP(OWNR,PLIEN,PDA,CVAL,PTYP)
+12 IF RESULT=-1
SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
QUIT
End DoDot:2
QUIT
+13 SET PVAL=PVAL_CVAL_$CHAR(29)
End DoDot:1
+14 IF PVAL'=""
Begin DoDot:1
+15 SET (DA,PDA)=$$ANP(OWNR,PLIEN,CNAME)
+16 IF DA=-1
SET II=II+1
SET @DATA@(II)="-1"_$CHAR(30)
QUIT
+17 SET CVAL=$$TKO^BQIUL1(PVAL,$CHAR(29))
+18 SET RESULT=$$UPP(OWNR,PLIEN,PDA,CVAL,PTYP)
+19 IF RESULT=-1
SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
QUIT
End DoDot:1
+20 QUIT
+21 ;
CRMP ;
+1 SET (DA,PDA)=$$ANP(OWNR,PLIEN,CNAME)
+2 IF DA=-1
SET II=II+1
SET @DATA@(II)="-1"_$CHAR(30)
SET QFL=1
QUIT
+3 SET CVAL=$$TKO^BQIUL1(PVAL,$CHAR(29))
+4 SET RESULT=$$UPP(OWNR,PLIEN,PDA,CVAL,PTYP)
+5 IF RESULT=-1
SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
SET QFL=1
QUIT
+6 QUIT
