- 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