- 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
