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
