- BQIMULST ;VNGT/HS/ALA-Provider List ; 28 Apr 2011 12:23 PM
- ;;2.3;ICARE MANAGEMENT SYSTEM;**1**;Apr 18, 2012;Build 43
- ;
- ;
- EN(DATA,FAKE) ; EP -- BQI GET LIST MU PROV
- NEW UID,II,PR
- S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
- S DATA=$NA(^TMP("BQIMULST",UID))
- K @DATA
- S II=0,TYPE=$G(TYPE,"")
- NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIMULST D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
- ;
- S HDR="I00010IEN^T00050"
- S @DATA@(II)=HDR_$C(30)
- S PR=0
- F S PR=$O(^BQI(90508,1,14,"B",PR)) Q:'PR D
- . S USN="",TYPE=""
- . F S USN=$O(^USR(8930.3,"B",PR,USN),-1) Q:USN="" D
- .. I '$$CURRENT^USRLM(USN) Q
- .. S TYPE=$P(^USR(8930.3,USN,0),U,2)
- .. ;I $O(^BQI(90508,1,13,"B",TYPE,""))="" S TYPE="" Q
- .. I TYPE'="" S TYPE=$S($P($G(^USR(8930,TYPE,0)),U,4)'="":$P($G(^USR(8930,TYPE,0)),U,4),1:$P($G(^USR(8930,TYPE,0)),U,1))
- . S II=II+1,@DATA@(II)=PR_U_$P(^VA(200,PR,0),U,1)_" ("_TYPE_")"_$C(30)
- ;
- DONE ;
- S II=II+1,@DATA@(II)=$C(31)
- 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,PLIST) ; EP -- BQI UPDATE LIST MU PROV
- ;
- NEW RESULT,ERROR,LIST,BN,BQ,PDATA,NAME,VALUE,BI,BQIUPD
- 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^T001024ERROR"_$C(30)
- ;
- NEW DA,DIK
- S DA(1)=1,DIK="^BQI(90508,"_DA(1)_",14,",DA=0
- F S DA=$O(^BQI(90508,DA(1),14,DA)) Q:'DA D ^DIK
- K ^XTMP("BQIPROV")
- ;
- 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=""
- . S DA=$O(^BQI(90508,0))
- . I $G(^BQI(90508,DA,14,0))="" S ^BQI(90508,DA,14,0)="^90508.014P^^"
- . S DA(1)=DA,DIC(0)="LNZ",DLAYGO=90508.014,DIC="^BQI(90508,"_DA(1)_",14,"
- . 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 Q
- . I $G(^BQIPROV(PRV,0))="" S ^BQIPROV(PRV,0)=PRV,^BQIPROV("B",PRV,PRV)="",^XTMP("BQIPROV",PRV)=""
- . I $G(^BQIPROV(PRV,50,0))="" S ^BQIPROV(PRV,50,0)="^90505.45D^^",^XTMP("BQIPROV",PRV)=""
- ;
- S II=II+1,@DATA@(II)=RESULT_U_$C(30)
- S II=II+1,@DATA@(II)=$C(31)
- Q
- ;
- I $D(^XTMP("BQIPROV")),$P($G(^BQI(90508,1,12)),U,6)="" D
- . NEW DESC,BJOB,BCJOB,BQPROH,BQIMUDTM,BQIMUDT,BQIMUTIM,CDOW
- . S BQPROH=+$P(^BQI(90508,1,12),U,7)
- . S BQIMUDTM=$$NOW^XLFDT(),BQIMUDT=$P(BQIMUDTM,".",1),BQIMUTIM=$P(BQIMUDTM,".",2)
- . S CDOW=$$DOW^XLFDT(BQIMUDT,1)
- . I CDOW'=6,CDOW'=0,BQPROH,$E(BQIMUTIM,1,2)+3>6,$E(BQIMUTIM,1,2)+3<18 D Q
- .. S ZTDTH=BQIMUDT_".183"
- .. S ZTDESC="MU CQ Provider Update",ZTRTN="PROV^BQITASK6",ZTIO=""
- .. S ZTSAVE("BGPPROV")=BGPPROV
- .. D ^%ZTLOAD
- .. S BQIUPD(90508,"1,",12.06)=ZTSK
- .. D FILE^DIE("","BQIUPD","ERROR")
- .. K ZTDESC,ZTRTN,ZTIO,ZTDTH,ZTSK
- Q
- BQIMULST ;VNGT/HS/ALA-Provider List ; 28 Apr 2011 12:23 PM
- +1 ;;2.3;ICARE MANAGEMENT SYSTEM;**1**;Apr 18, 2012;Build 43
- +2 ;
- +3 ;
- EN(DATA,FAKE) ; EP -- BQI GET LIST MU PROV
- +1 NEW UID,II,PR
- +2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
- +3 SET DATA=$NAME(^TMP("BQIMULST",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^BQIMULST D UNWIND^%ZTER"
- +7 ;
- +8 SET HDR="I00010IEN^T00050"
- +9 SET @DATA@(II)=HDR_$CHAR(30)
- +10 SET PR=0
- +11 FOR
- SET PR=$ORDER(^BQI(90508,1,14,"B",PR))
- IF 'PR
- QUIT
- Begin DoDot:1
- +12 SET USN=""
- SET TYPE=""
- +13 FOR
- SET USN=$ORDER(^USR(8930.3,"B",PR,USN),-1)
- IF USN=""
- QUIT
- Begin DoDot:2
- +14 IF '$$CURRENT^USRLM(USN)
- QUIT
- +15 SET TYPE=$PIECE(^USR(8930.3,USN,0),U,2)
- +16 ;I $O(^BQI(90508,1,13,"B",TYPE,""))="" S TYPE="" Q
- +17 IF TYPE'=""
- SET TYPE=$SELECT($PIECE($GET(^USR(8930,TYPE,0)),U,4)'="":$PIECE($GET(^USR(8930,TYPE,0)),U,4),1:$PIECE($GET(^USR(8930,TYPE,0)),U,1))
- End DoDot:2
- +18 SET II=II+1
- SET @DATA@(II)=PR_U_$PIECE(^VA(200,PR,0),U,1)_" ("_TYPE_")"_$CHAR(30)
- End DoDot:1
- +19 ;
- DONE ;
- +1 SET II=II+1
- SET @DATA@(II)=$CHAR(31)
- +2 QUIT
- +3 ;
- 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,PLIST) ; EP -- BQI UPDATE LIST MU PROV
- +1 ;
- +2 NEW RESULT,ERROR,LIST,BN,BQ,PDATA,NAME,VALUE,BI,BQIUPD
- +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^T001024ERROR"_$CHAR(30)
- +10 ;
- +11 NEW DA,DIK
- +12 SET DA(1)=1
- SET DIK="^BQI(90508,"_DA(1)_",14,"
- SET DA=0
- +13 FOR
- SET DA=$ORDER(^BQI(90508,DA(1),14,DA))
- IF 'DA
- QUIT
- DO ^DIK
- +14 KILL ^XTMP("BQIPROV")
- +15 ;
- +16 SET PLIST=$GET(PLIST,"")
- +17 IF PLIST=""
- Begin DoDot:1
- +18 SET LIST=""
- SET BN=""
- +19 FOR
- SET BN=$ORDER(PLIST(BN))
- IF BN=""
- QUIT
- SET LIST=LIST_PLIST(BN)
- +20 KILL PLIST
- +21 SET PLIST=LIST
- +22 KILL LIST
- End DoDot:1
- +23 ;
- +24 SET RESULT=1
- +25 FOR BQ=1:1:$LENGTH(PLIST,$CHAR(29))
- Begin DoDot:1
- +26 SET PRV=$PIECE(PLIST,$CHAR(29),BQ)
- IF PRV=""
- QUIT
- +27 SET DA=$ORDER(^BQI(90508,0))
- +28 IF $GET(^BQI(90508,DA,14,0))=""
- SET ^BQI(90508,DA,14,0)="^90508.014P^^"
- +29 SET DA(1)=DA
- SET DIC(0)="LNZ"
- SET DLAYGO=90508.014
- SET DIC="^BQI(90508,"_DA(1)_",14,"
- +30 IF $PIECE($GET(^VA(200,PRV,0)),U,11)'=""
- IF $PIECE($GET(^VA(200,PRV,0)),U,11)<3090101
- SET RESULT=-1
- QUIT
- +31 IF PRV=1
- IF $PIECE($GET(^VA(200,PRV,0)),U,1)["ADAM"
- QUIT
- +32 SET X=PRV
- +33 KILL DO,DD
- DO FILE^DICN
- +34 IF Y=-1
- SET RESULT=-1
- QUIT
- +35 IF $GET(^BQIPROV(PRV,0))=""
- SET ^BQIPROV(PRV,0)=PRV
- SET ^BQIPROV("B",PRV,PRV)=""
- SET ^XTMP("BQIPROV",PRV)=""
- +36 IF $GET(^BQIPROV(PRV,50,0))=""
- SET ^BQIPROV(PRV,50,0)="^90505.45D^^"
- SET ^XTMP("BQIPROV",PRV)=""
- End DoDot:1
- IF $GET(BMXSEC)'=""
- QUIT
- +37 ;
- +38 SET II=II+1
- SET @DATA@(II)=RESULT_U_$CHAR(30)
- +39 SET II=II+1
- SET @DATA@(II)=$CHAR(31)
- +40 QUIT
- +41 ;
- +42 IF $DATA(^XTMP("BQIPROV"))
- IF $PIECE($GET(^BQI(90508,1,12)),U,6)=""
- Begin DoDot:1
- +43 NEW DESC,BJOB,BCJOB,BQPROH,BQIMUDTM,BQIMUDT,BQIMUTIM,CDOW
- +44 SET BQPROH=+$PIECE(^BQI(90508,1,12),U,7)
- +45 SET BQIMUDTM=$$NOW^XLFDT()
- SET BQIMUDT=$PIECE(BQIMUDTM,".",1)
- SET BQIMUTIM=$PIECE(BQIMUDTM,".",2)
- +46 SET CDOW=$$DOW^XLFDT(BQIMUDT,1)
- +47 IF CDOW'=6
- IF CDOW'=0
- IF BQPROH
- IF $EXTRACT(BQIMUTIM,1,2)+3>6
- IF $EXTRACT(BQIMUTIM,1,2)+3<18
- Begin DoDot:2
- +48 SET ZTDTH=BQIMUDT_".183"
- +49 SET ZTDESC="MU CQ Provider Update"
- SET ZTRTN="PROV^BQITASK6"
- SET ZTIO=""
- +50 SET ZTSAVE("BGPPROV")=BGPPROV
- +51 DO ^%ZTLOAD
- +52 SET BQIUPD(90508,"1,",12.06)=ZTSK
- +53 DO FILE^DIE("","BQIUPD","ERROR")
- +54 KILL ZTDESC,ZTRTN,ZTIO,ZTDTH,ZTSK
- End DoDot:2
- QUIT
- End DoDot:1
- +55 QUIT
