BQISYDIV ;GDIT/HS/ALA-Divisions ; 16 Oct 2012 4:12 PM
;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66
;
FND ; EP - Find all divisions
; User file
K ^XTMP("BQISYDIV")
S ^XTMP("BQISYDIV",0)=$$FMADD^XLFDT(DT,365)_U_DT_U_"Division list"
S N=0
F S N=$O(^VA(200,N)) Q:'N D
. I $P($G(^VA(200,N,0)),U,11)'="",$P(^VA(200,N,0),U,11)<DT Q
. S L=0 F S L=$O(^VA(200,N,2,L)) Q:'L D
.. S NAME=$P($G(^DIC(4,L,0)),U,1) I NAME="" Q
.. I $P(^AUTTLOC(L,0),U,21)'="",$P(^AUTTLOC(L,0),U,21)<DT Q
.. S ^XTMP("BQISYDIV",NAME)=L
;
S N=0
F S N=$O(^AUPNPAT(N)) Q:'N D
. S L=0 F S L=$O(^AUPNPAT(N,41,L)) Q:'L D
.. I $P(^AUPNPAT(N,41,L,0),"^",3)'="" Q
.. S NAME=$P($G(^DIC(4,L,0)),U,1) I NAME="" Q
.. I $P($G(^AUTTLOC(L,0)),U,21)'="",$P(^AUTTLOC(L,0),U,21)<DT Q
.. S ^XTMP("BQISYDIV",NAME)=L
Q
;
GET(DATA,FAKE) ;EP - BQI GET SITE DIVISIONS
; Get specific MU system parameters from the Site Parameter file
NEW UID,II,IEN,CN,BQDIVN
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIMUSIT",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQISYDIV D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S @DATA@(II)="I00010IEN^T00060DIVISION"_$C(30)
;
S IEN=$O(^BQI(90508,0)) I IEN="" S BMXSEC="No site defined" Q
S CN=0
F S CN=$O(^BQI(90508,IEN,25,CN)) Q:'CN D
. S BQDIVN=$P(^BQI(90508,IEN,25,CN,0),U,1)
. S II=II+1,@DATA@(II)=BQDIVN_U_$P($G(^DIC(4,BQDIVN,0)),U,1)_$C(30)
;
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 SET SITE DIVISIONS
NEW RESULT,ERROR,LIST,BN,BQ,PDATA,NAME,VALUE,BI,BQIUPD,BQDIV
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIUSYPRM",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQISYDIV D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S @DATA@(II)="I00010RESULT^T01024ERROR"_$C(30)
;
NEW DA,DIK
S DA(1)=1,DIK="^BQI(90508,"_DA(1)_",25,",DA=0
F S DA=$O(^BQI(90508,DA(1),25,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 BQDIV=$P(PLIST,$C(29),BQ) Q:BQDIV=""
. S DA=$O(^BQI(90508,0))
. I $G(^BQI(90508,DA,25,0))="" S ^BQI(90508,DA,25,0)="^90508.025P^^"
. S DA(1)=DA,DIC(0)="LNZ",DLAYGO=90508.025,DIC="^BQI(90508,"_DA(1)_",25,"
. S X=BQDIV
. 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
;
USR(DATA,FAKE) ;EP -- BQI GET USER DIVISIONS
NEW UID
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIUSRDIV",UID))
K @DATA
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQISYDIV D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
D GETFCRS^BMXRPC10(.DATA,DUZ)
Q
BQISYDIV ;GDIT/HS/ALA-Divisions ; 16 Oct 2012 4:12 PM
+1 ;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66
+2 ;
FND ; EP - Find all divisions
+1 ; User file
+2 KILL ^XTMP("BQISYDIV")
+3 SET ^XTMP("BQISYDIV",0)=$$FMADD^XLFDT(DT,365)_U_DT_U_"Division list"
+4 SET N=0
+5 FOR
SET N=$ORDER(^VA(200,N))
IF 'N
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(^VA(200,N,0)),U,11)'=""
IF $PIECE(^VA(200,N,0),U,11)<DT
QUIT
+7 SET L=0
FOR
SET L=$ORDER(^VA(200,N,2,L))
IF 'L
QUIT
Begin DoDot:2
+8 SET NAME=$PIECE($GET(^DIC(4,L,0)),U,1)
IF NAME=""
QUIT
+9 IF $PIECE(^AUTTLOC(L,0),U,21)'=""
IF $PIECE(^AUTTLOC(L,0),U,21)<DT
QUIT
+10 SET ^XTMP("BQISYDIV",NAME)=L
End DoDot:2
End DoDot:1
+11 ;
+12 SET N=0
+13 FOR
SET N=$ORDER(^AUPNPAT(N))
IF 'N
QUIT
Begin DoDot:1
+14 SET L=0
FOR
SET L=$ORDER(^AUPNPAT(N,41,L))
IF 'L
QUIT
Begin DoDot:2
+15 IF $PIECE(^AUPNPAT(N,41,L,0),"^",3)'=""
QUIT
+16 SET NAME=$PIECE($GET(^DIC(4,L,0)),U,1)
IF NAME=""
QUIT
+17 IF $PIECE($GET(^AUTTLOC(L,0)),U,21)'=""
IF $PIECE(^AUTTLOC(L,0),U,21)<DT
QUIT
+18 SET ^XTMP("BQISYDIV",NAME)=L
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
GET(DATA,FAKE) ;EP - BQI GET SITE DIVISIONS
+1 ; Get specific MU system parameters from the Site Parameter file
+2 NEW UID,II,IEN,CN,BQDIVN
+3 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+4 SET DATA=$NAME(^TMP("BQIMUSIT",UID))
+5 KILL @DATA
+6 ;
+7 SET II=0
+8 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQISYDIV D UNWIND^%ZTER"
+9 ;
+10 SET @DATA@(II)="I00010IEN^T00060DIVISION"_$CHAR(30)
+11 ;
+12 SET IEN=$ORDER(^BQI(90508,0))
IF IEN=""
SET BMXSEC="No site defined"
QUIT
+13 SET CN=0
+14 FOR
SET CN=$ORDER(^BQI(90508,IEN,25,CN))
IF 'CN
QUIT
Begin DoDot:1
+15 SET BQDIVN=$PIECE(^BQI(90508,IEN,25,CN,0),U,1)
+16 SET II=II+1
SET @DATA@(II)=BQDIVN_U_$PIECE($GET(^DIC(4,BQDIVN,0)),U,1)_$CHAR(30)
End DoDot:1
+17 ;
+18 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+19 QUIT
+20 ;
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 SET SITE DIVISIONS
+1 NEW RESULT,ERROR,LIST,BN,BQ,PDATA,NAME,VALUE,BI,BQIUPD,BQDIV
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 SET DATA=$NAME(^TMP("BQIUSYPRM",UID))
+4 KILL @DATA
+5 ;
+6 SET II=0
+7 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQISYDIV D UNWIND^%ZTER"
+8 SET @DATA@(II)="I00010RESULT^T01024ERROR"_$CHAR(30)
+9 ;
+10 NEW DA,DIK
+11 SET DA(1)=1
SET DIK="^BQI(90508,"_DA(1)_",25,"
SET DA=0
+12 FOR
SET DA=$ORDER(^BQI(90508,DA(1),25,DA))
IF 'DA
QUIT
DO ^DIK
+13 ;
+14 SET PLIST=$GET(PLIST,"")
+15 IF PLIST=""
Begin DoDot:1
+16 SET LIST=""
SET BN=""
+17 FOR
SET BN=$ORDER(PLIST(BN))
IF BN=""
QUIT
SET LIST=LIST_PLIST(BN)
+18 KILL PLIST
+19 SET PLIST=LIST
+20 KILL LIST
End DoDot:1
+21 ;
+22 SET RESULT=1
+23 FOR BQ=1:1:$LENGTH(PLIST,$CHAR(29))
Begin DoDot:1
+24 SET BQDIV=$PIECE(PLIST,$CHAR(29),BQ)
IF BQDIV=""
QUIT
+25 SET DA=$ORDER(^BQI(90508,0))
+26 IF $GET(^BQI(90508,DA,25,0))=""
SET ^BQI(90508,DA,25,0)="^90508.025P^^"
+27 SET DA(1)=DA
SET DIC(0)="LNZ"
SET DLAYGO=90508.025
SET DIC="^BQI(90508,"_DA(1)_",25,"
+28 SET X=BQDIV
+29 KILL DO,DD
DO FILE^DICN
+30 IF Y=-1
SET RESULT=-1
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+31 ;
+32 SET II=II+1
SET @DATA@(II)=RESULT_U_$CHAR(30)
+33 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+34 QUIT
+35 ;
USR(DATA,FAKE) ;EP -- BQI GET USER DIVISIONS
+1 NEW UID
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 SET DATA=$NAME(^TMP("BQIUSRDIV",UID))
+4 KILL @DATA
+5 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQISYDIV D UNWIND^%ZTER"
+6 DO GETFCRS^BMXRPC10(.DATA,DUZ)
+7 QUIT
