BQIIPSIT ;GDIT/HS/ALA-IPC Site Parameters ; 11 Oct 2011 4:31 PM
;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
;
;
GET(DATA,FAKE) ; EP -- BQI GET IPC SITE PARMS
NEW UID,II,DA,DOM,TEST1,VALUE,BM,BX,MIN,MAX
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIIPSIT",UID))
K @DATA
S II=0,TYPE=$G(TYPE,"")
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQISYPRM D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S HDR="T00001DAYOFMONTH^T00001HIDE_MIN^T00001HIDE_MAX"
S @DATA@(II)=HDR_$C(30)
S DA=$$SPM^BQIGPUTL()
S DOM=$$GET1^DIQ(90508,DA_",",11.02,"E")
;
D FIELD^DID(90508,11.02,"","HELP-PROMPT;FIELD LENGTH","TEST1")
S VALUE=$G(TEST1("HELP-PROMPT")),LEN=$G(TEST1("FIELD LENGTH"))
S BM=$F(VALUE,"between "),MIN=$E(VALUE,BM)
S BX=$F(VALUE,"and ")
S MAX=$S(LEN=1:$E(VALUE,BX),1:$E(VALUE,BX,BX+1))
S II=II+1,@DATA@(II)=DOM_U_MIN_U_MAX_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
UPD(DATA,DOM) ;EP -- BQI SET IPC SITE PARMS
NEW RESULT,ERROR,RESULT,BQIUPD,MSG,DA
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIUIPST",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQISYPRM D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S @DATA@(II)="I00010RESULT^T01024ERROR"_$C(30)
;
S RESULT=1,MSG=""
S:$G(DOM)="" DOM=1
S DA=$$SPM^BQIGPUTL()
I $G(DOM)'="" S BQIUPD(90508,DA_",",11.02)=DOM
I $D(BQIUPD) D FILE^DIE("E","BQIUPD","ERROR")
I $D(ERROR) S RESULT=-1,MSG=$G(ERROR("DIERR",1,"TEXT",1))
;
S II=II+1,@DATA@(II)=RESULT_U_MSG_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
PRV(DATA,FAKE) ; EP - BQI GET IPC MICRO PROV
NEW UID,II,PR,CRIPC,CRN,DA
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIMICRO",UID))
K @DATA
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIMULST D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
; Get current IPC
S CRIPC=$P($G(^BQI(90508,1,11)),U,1)
S CRN=$O(^BQI(90508,1,22,"B",CRIPC,"")) I CRN="" Q
S DA(1)=CRN
S DA(2)=$$SPM^BQIGPUTL()
S HDR="I00010IEN^T00050MICRO_PROV"
S @DATA@(II)=HDR_$C(30)
S PR=""
F S PR=$O(^BQI(90508,DA(2),22,DA(1),2,"B",PR)) Q:PR="" D
. S II=II+1,@DATA@(II)=PR_U_$P(^VA(200,PR,0),U,1)_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
UPP(DATA,PLIST) ; EP - BQI UDPATE IPC MICRO PROV
NEW RESULT,ERROR,LIST,BN,BQ,PDATA,NAME,VALUE,BI,BQIUPD,DA,CRIPC,CRN
NEW DIC,DLAYGO,PRV,X,Y
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIUMULS",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIMULST D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S @DATA@(II)="I00010RESULT^T01024ERROR"_$C(30)
;
; Get current IPC
S CRIPC=$P($G(^BQI(90508,1,11)),U,1)
S CRN=$O(^BQI(90508,1,22,"B",CRIPC,"")) I CRN="" Q
S DA(1)=CRN
S DA(2)=$$SPM^BQIGPUTL()
; Delete previous microsystem providers
NEW DIK
S DIK="^BQI(90508,"_DA(2)_",22,"_DA(1)_",2,",DA=0
F S DA=$O(^BQI(90508,DA(2),22,DA(1),2,DA)) Q:'DA D ^DIK
;
S PLIST=$G(PLIST,"")
I PLIST="" D
. S LIST="",BN=""
. F S BN=$O(PLIST(BN)) Q:BN="" S LIST=LIST_PLIST(BN)
. K PLIST
. S PLIST=LIST
. K LIST
;
S RESULT=1
F BQ=1:1:$L(PLIST,$C(29)) D Q:$G(BMXSEC)'=""
. S PRV=$P(PLIST,$C(29),BQ) Q:PRV=""
. I $G(^BQI(90508,DA(2),22,DA(1),2,0))="" S ^BQI(90508,DA(2),22,DA(1),2,0)="^90508.222P^^"
. S DIC(0)="LNZ",DLAYGO=90508.222,DIC="^BQI(90508,"_DA(2)_",22,"_DA(1)_",2,"
. ;I $P($G(^VA(200,PRV,0)),U,11)'="",$P($G(^VA(200,PRV,0)),U,11)<3090101 S RESULT=-1 Q
. I PRV=1,$P($G(^VA(200,PRV,0)),U,1)["ADAM" Q
. S X=PRV
. K DO,DD D FILE^DICN
. I Y=-1 S RESULT=-1
;
S II=II+1,@DATA@(II)=RESULT_U_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
BQIIPSIT ;GDIT/HS/ALA-IPC Site Parameters ; 11 Oct 2011 4:31 PM
+1 ;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
+2 ;
+3 ;
GET(DATA,FAKE) ; EP -- BQI GET IPC SITE PARMS
+1 NEW UID,II,DA,DOM,TEST1,VALUE,BM,BX,MIN,MAX
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 SET DATA=$NAME(^TMP("BQIIPSIT",UID))
+4 KILL @DATA
+5 SET II=0
SET TYPE=$GET(TYPE,"")
+6 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQISYPRM D UNWIND^%ZTER"
+7 ;
+8 SET HDR="T00001DAYOFMONTH^T00001HIDE_MIN^T00001HIDE_MAX"
+9 SET @DATA@(II)=HDR_$CHAR(30)
+10 SET DA=$$SPM^BQIGPUTL()
+11 SET DOM=$$GET1^DIQ(90508,DA_",",11.02,"E")
+12 ;
+13 DO FIELD^DID(90508,11.02,"","HELP-PROMPT;FIELD LENGTH","TEST1")
+14 SET VALUE=$GET(TEST1("HELP-PROMPT"))
SET LEN=$GET(TEST1("FIELD LENGTH"))
+15 SET BM=$FIND(VALUE,"between ")
SET MIN=$EXTRACT(VALUE,BM)
+16 SET BX=$FIND(VALUE,"and ")
+17 SET MAX=$SELECT(LEN=1:$EXTRACT(VALUE,BX),1:$EXTRACT(VALUE,BX,BX+1))
+18 SET II=II+1
SET @DATA@(II)=DOM_U_MIN_U_MAX_$CHAR(30)
+19 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+20 QUIT
+21 ;
UPD(DATA,DOM) ;EP -- BQI SET IPC SITE PARMS
+1 NEW RESULT,ERROR,RESULT,BQIUPD,MSG,DA
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 SET DATA=$NAME(^TMP("BQIUIPST",UID))
+4 KILL @DATA
+5 ;
+6 SET II=0
+7 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQISYPRM D UNWIND^%ZTER"
+8 SET @DATA@(II)="I00010RESULT^T01024ERROR"_$CHAR(30)
+9 ;
+10 SET RESULT=1
SET MSG=""
+11 IF $GET(DOM)=""
SET DOM=1
+12 SET DA=$$SPM^BQIGPUTL()
+13 IF $GET(DOM)'=""
SET BQIUPD(90508,DA_",",11.02)=DOM
+14 IF $DATA(BQIUPD)
DO FILE^DIE("E","BQIUPD","ERROR")
+15 IF $DATA(ERROR)
SET RESULT=-1
SET MSG=$GET(ERROR("DIERR",1,"TEXT",1))
+16 ;
+17 SET II=II+1
SET @DATA@(II)=RESULT_U_MSG_$CHAR(30)
+18 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+19 QUIT
+20 ;
PRV(DATA,FAKE) ; EP - BQI GET IPC MICRO PROV
+1 NEW UID,II,PR,CRIPC,CRN,DA
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 SET DATA=$NAME(^TMP("BQIMICRO",UID))
+4 KILL @DATA
+5 SET II=0
+6 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIMULST D UNWIND^%ZTER"
+7 ;
+8 ; Get current IPC
+9 SET CRIPC=$PIECE($GET(^BQI(90508,1,11)),U,1)
+10 SET CRN=$ORDER(^BQI(90508,1,22,"B",CRIPC,""))
IF CRN=""
QUIT
+11 SET DA(1)=CRN
+12 SET DA(2)=$$SPM^BQIGPUTL()
+13 SET HDR="I00010IEN^T00050MICRO_PROV"
+14 SET @DATA@(II)=HDR_$CHAR(30)
+15 SET PR=""
+16 FOR
SET PR=$ORDER(^BQI(90508,DA(2),22,DA(1),2,"B",PR))
IF PR=""
QUIT
Begin DoDot:1
+17 SET II=II+1
SET @DATA@(II)=PR_U_$PIECE(^VA(200,PR,0),U,1)_$CHAR(30)
End DoDot:1
+18 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+19 QUIT
+20 ;
UPP(DATA,PLIST) ; EP - BQI UDPATE IPC MICRO PROV
+1 NEW RESULT,ERROR,LIST,BN,BQ,PDATA,NAME,VALUE,BI,BQIUPD,DA,CRIPC,CRN
+2 NEW DIC,DLAYGO,PRV,X,Y
+3 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+4 SET DATA=$NAME(^TMP("BQIUMULS",UID))
+5 KILL @DATA
+6 ;
+7 SET II=0
+8 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIMULST D UNWIND^%ZTER"
+9 SET @DATA@(II)="I00010RESULT^T01024ERROR"_$CHAR(30)
+10 ;
+11 ; Get current IPC
+12 SET CRIPC=$PIECE($GET(^BQI(90508,1,11)),U,1)
+13 SET CRN=$ORDER(^BQI(90508,1,22,"B",CRIPC,""))
IF CRN=""
QUIT
+14 SET DA(1)=CRN
+15 SET DA(2)=$$SPM^BQIGPUTL()
+16 ; Delete previous microsystem providers
+17 NEW DIK
+18 SET DIK="^BQI(90508,"_DA(2)_",22,"_DA(1)_",2,"
SET DA=0
+19 FOR
SET DA=$ORDER(^BQI(90508,DA(2),22,DA(1),2,DA))
IF 'DA
QUIT
DO ^DIK
+20 ;
+21 SET PLIST=$GET(PLIST,"")
+22 IF PLIST=""
Begin DoDot:1
+23 SET LIST=""
SET BN=""
+24 FOR
SET BN=$ORDER(PLIST(BN))
IF BN=""
QUIT
SET LIST=LIST_PLIST(BN)
+25 KILL PLIST
+26 SET PLIST=LIST
+27 KILL LIST
End DoDot:1
+28 ;
+29 SET RESULT=1
+30 FOR BQ=1:1:$LENGTH(PLIST,$CHAR(29))
Begin DoDot:1
+31 SET PRV=$PIECE(PLIST,$CHAR(29),BQ)
IF PRV=""
QUIT
+32 IF $GET(^BQI(90508,DA(2),22,DA(1),2,0))=""
SET ^BQI(90508,DA(2),22,DA(1),2,0)="^90508.222P^^"
+33 SET DIC(0)="LNZ"
SET DLAYGO=90508.222
SET DIC="^BQI(90508,"_DA(2)_",22,"_DA(1)_",2,"
+34 ;I $P($G(^VA(200,PRV,0)),U,11)'="",$P($G(^VA(200,PRV,0)),U,11)<3090101 S RESULT=-1 Q
+35 IF PRV=1
IF $PIECE($GET(^VA(200,PRV,0)),U,1)["ADAM"
QUIT
+36 SET X=PRV
+37 KILL DO,DD
DO FILE^DICN
+38 IF Y=-1
SET RESULT=-1
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+39 ;
+40 SET II=II+1
SET @DATA@(II)=RESULT_U_$CHAR(30)
+41 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+42 QUIT
