- 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
