BMXRPC3 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ; 23 Jul 2009 3:03 PM
;;4.0;BMX;;JUN 28, 2010
;
;
VARVAL(RESULT,VARIABLE) ;returns value of passed in variable
S VARIABLE=$TR(VARIABLE,"~","^")
S RESULT=VARIABLE ;can do this with the REFERENCE type parameter
Q
;See GETV^XWBBRK for how we get the REFERENCE type parameter
;
USER(RESULT,D) ;
;
I '+D S RESULT="" Q
S RESULT=$P($G(^VA(200,D,0)),"^")
Q
;
NTUSER(BMXY,BMXNTUSE) ;EP
;Old code. Retain for reference
;Returns NTDomain^NTUserName^RPMSName for user having DUZ=D
;TODO: Move ANMC NT USERS file
;from AZZWNT to BMX namespace and numberspace
;
;N BMX,BMXNOD,BMXDOM,BMXNAM,BMXCOL,BMXRNAM
;S (BMXDOM,BMXNAM,BMXRNAM)=""
;S U="^"
;I '+D S RESULT="" Q
;S BMXRNAM=$G(^VA(200,D,0)),BMXRNAM=$P(BMXRNAM,U)
;I '$D(^AZZWNT("DUZ",D)) D NTU1 Q
;S BMX=$O(^AZZWNT("DUZ",D,0))
;I '+BMX D NTU1 Q
;I '$D(^AZZWNT(BMX,0)) D NTU1 Q
;S BMXNOD=^AZZWNT(BMX,0)
;S BMXDOM=$P(BMXNOD,U,2)
;S BMXNAM=$P(BMXNOD,U) ;,4)
;D NTU1
Q
;
;
NTUGETD(BMXY,BMXNTNAM) ;EP
;Entry point for debugging
;
;D DEBUG^%Serenji("NTUGETD^BMXRPC3(.BMXY,BMXNTNAM)")
Q
;
NTUGET(BMXY,BMXNTNAM) ;EP
;
;Returns A ENCRYPTED and V ENCRYPTED for NT User BMXNTNM
;Called by RPC BMXNetGetCodes
N BMXI,BMXNTID,BMXNTID,BMXNOD,BMXA,BMXV
S BMXI=0
S BMXY="^BMXTMP("_$J_")"
S X="NTUET^BMXRPC3",@^%ZOSF("TRAP")
S BMXI=BMXI+1
I BMXNTNM="" S ^BMXTMP($J,BMXI)="^" Q
S BMXNTID=$O(^BMXUSER("B",BMXNTNAM,0))
I '+BMXNTID S ^BMXTMP($J,BMXI)="^" Q
S BMXNOD=$G(^BMXUSER(BMXNTID,0))
S BMXA=$P(BMXNOD,U,2)
S BMXV=$P(BMXNOD,U,3)
S ^BMXTMP($J,BMXI)=BMXA_"^"_BMXV_"^"
Q
;
WINUGET(BMXWINID) ;EP
;Returns DUZ for user having Windows Identity BMXWINID
;Returns 0 if no Windows user found
;
N BMXIEN,BMXNOD,BMXDUZ
I BMXWINID="" Q 0
S BMXIEN=$O(^BMXUSER("B",BMXWINID,0))
I '+BMXIEN Q 0
S BMXNOD=$G(^BMXUSER(BMXIEN,0))
S BMXDUZ=$P(BMXNOD,U,2)
Q BMXDUZ
;
NTUSET(BMXY,BMXNTNAM) ;EP
;Sets NEW PERSON map entry for Windows Identity BMXNTNM
;Returns ERRORID 0 if all ok
;Called by RPC BMXNetSetUser
;
;
N BMXI,BMXNTID,BMXFDA,BMXF,BMXIEN,BMXMSG,BMXAPPTD
S BMXI=0
S BMXY="^BMXTMP("_$J_")"
S X="NTUET^BMXRPC3",@^%ZOSF("TRAP")
S BMXI=BMXI+1
; Quit with error if no DUZ exists
I '+$G(DUZ) D NTUERR(BMXI,500) Q
; Create entry or file in existing entry in BMX USER
I $D(^BMXUSER("B",BMXNTNAM)) S BMXF="?1,"
E S BMXF="+1,"
S BMXFDA(90093.1,BMXF,.01)=BMXNTNAM
S BMXFDA(90093.1,BMXF,.02)=$G(DUZ)
K BMXIEN,BMXMSG
D UPDATE^DIE("","BMXFDA","BMXIEN","BMXMSG")
S BMXAPPTD=+$G(BMXIEN(1))
S BMXI=BMXI+1
S ^BMXTMP($J,BMXI)=BMXAPPTD_"^0"
Q
;
NTUET ;EP
;Error trap from REGEVNT
;
I '$D(BMXI) N BMXI S BMXI=999
S BMXI=BMXI+1
D NTUERR(BMXI,99)
Q
;
NTUERR(BMXI,BMXERID) ;Error processing
S BMXI=BMXI+1
S ^BMXTMP($J,BMXI)="^"_BMXERID
Q
;
;
NTU1 ;S BMXCOL="T00030NT_DOMAIN^T00030NT_USERNAME^T00030RPMS_USERNAME"_$C(30)
;S RESULT=BMXCOL_BMXDOM_U_BMXNAM_U_BMXRNAM_$C(30)_$C(31)
Q
;
GETFC(BMXFACS,DUZ) ;Gets all facilities for a user
; Input DUZ - user IEN from the NEW PERSON FILE
; Output - Number of facilities;facility1 name&facility1 IEN;...facilityN&facilityN IEN
N BMXFN,BMXN
S BMXFN=0,BMXFACS=""
F BMXN=1:1 S BMXFN=$O(^VA(200,DUZ,2,BMXFN)) Q:BMXFN="" D
. S:BMXN>1 BMXFACS=BMXFACS_";" S BMXFACS=BMXFACS_$P(^DIC(4,BMXFN,0),U,1)_"&"_BMXFN
I BMXN=1 S BMXFN=$P(^AUTTSITE(1,0),U,1) D
. S BMXFACS=BMXFACS_$P(^DIC(4,BMXFN,0),U,1)_"&"_BMXFN
S BMXFACS=BMXN-(BMXN>1)_";"_BMXFACS
Q
;
GETFCRS(BMXFACS,BMXDUZ) ;Gets all facilities for a user - returns RECORDSET
;
;TODO: return as global array, add error checking
N BMXFN,BMXN,BMXSUB,BMXRCNT
S BMXDUZ=$TR(BMXDUZ,$C(13),"")
S BMXDUZ=$TR(BMXDUZ,$C(10),"")
S BMXDUZ=$TR(BMXDUZ,$C(9),"")
S BMXFN=0
S BMXSUB="^VA(200,"_BMXDUZ_",2,"
S BMXFACS="T00030FACILITY_NAME^T00030FACILITY_IEN^T00002MOST_RECENT_LOOKUP"_$C(30)
;F BMXN=1:1 S BMXFN=$O(^VA(200,BMXDUZ,2,BMXFN)) Q:BMXFN="" D
S BMXRCNT=0 ;cmi/maw mod 10/17/2006
F BMXN=1:1 S BMXFN=$O(^VA(200,BMXDUZ,2,BMXFN)) Q:'BMXFN D ;IHS/ANMC/LJF 8/9/01
. ;S BMXFACS=BMXFACS_$P(^DIC(4,BMXFN,0),U,1)_"^"_BMXFN_$C(30)
. S BMXFACS=BMXFACS_$P(^DIC(4,BMXFN,0),U,1)_"^"_BMXFN
. ;S BMXRCNT=0 ;cmi/maw orig
. ;I $D(^DISV(BMXDUZ,BMXSUB)),^DISV(BMXDUZ,BMXSUB)=BMXFN S BMXRCNT=1
. ;I $G(DUZ(2))=BMXFN S BMXRCNT=1 ;cmi/maw orig
. S BMXRCNT=BMXRCNT+1 ;cmi/maw mod
. S BMXFACS=BMXFACS_"^"_BMXRCNT_$C(30)
I BMXN=1 S BMXFN=$P(^AUTTSITE(1,0),U,1) D
. S BMXFACS=BMXFACS_$P(^DIC(4,BMXFN,0),U,1)_"^"_BMXFN_"^"_1_$C(30)
S BMXFACS=BMXFACS_$C(31)
Q
;
SETFCRS(BMXY,BMXFAC) ;
;
;Sets DUZ(2) to value in BMXFAC
;Fails if BMXFAC is not one of the current user's divisions
;Returns Recordset
;
S X="ERFC^BMXRPC3",@^%ZOSF("TRAP")
S BMXY="T00030DUZ^T00030FACILITY_IEN^T00030FACILITY_NAME"_$C(30)
N BMXSUB,BMXFACN
I '+DUZ S BMXY=BMXY_0_"^"_0_"^"_0_$C(30)_$C(31) Q
I '+BMXFAC S BMXY=BMXY_DUZ_"^"_0_"^"_0_$C(30)_$C(31) Q
;I '$D(^VA(200,DUZ,2,+BMXFAC,0)) S BMXY=BMXY_DUZ_"^"_0_"^"_0_$C(30)_$C(31) Q ; GIS/OIT Feb 9, 2010
S DUZ(2)=BMXFAC ;IHS/OIT/HMW SAC Exemption Applied For
S BMXFACN=$G(^DIC(4,+DUZ(2),0))
S BMXFACN=$P(BMXFACN,"^")
S BMXSUB="^VA(200,"_DUZ_",2,"
S ^DISV(DUZ,BMXSUB)=BMXFAC
S BMXY=BMXY_DUZ_"^"_BMXFAC_"^"_BMXFACN_$C(30)_$C(31)
Q
;
ERFC ;
D ^%ZTER
S BMXY=$G(BMXY)_0_"^"_0_$C(30)_$C(31) Q
Q
;
SETFC(BMXY,BMXFAC) ;
;Sets DUZ(2) to value in BMXFAC
;Fails if BMXFAC is not one of the current user's divisions
;Returns 1 if successful, 0 if failed
;
S BMXY=0
N BMXSUB
I '+DUZ S BMXY=0 Q
I '+BMXFAC S BMXY=0 Q
I '$D(^VA(200,DUZ,2,+BMXFAC,0)) S BMXY=0 Q
S DUZ(2)=BMXFAC ;IHS/OIT/HMW SAC Exemption Applied For
S BMXSUB="^VA(200,"_DUZ_",2,"
S ^DISV(DUZ,BMXSUB)=BMXFAC
S BMXY=1
Q
;
APSEC(BMXY,BMXKEY) ;EP
;Return IHSCD_SUCCEEDED (-1) if user has key BMXKEY
;OR if user has key XUPROGMODE
;Otherwise, returns IHSCD_FAILED (0)
N BMXIEN,BMXPROG,BMXPKEY
I '$G(DUZ) S BMXY=0 Q
I BMXKEY="" S BMXY=0 Q
;
;Test for programmer mode key
S BMXPROG=0
I $D(^DIC(19.1,"B","XUPROGMODE")) D
. S BMXPKEY=$O(^DIC(19.1,"B","XUPROGMODE",0))
. I '+BMXPKEY Q
. I '$D(^VA(200,DUZ,51,BMXPKEY,0)) Q
. S BMXPROG=1
I BMXPROG S BMXY=-1 Q
;
I '$D(^DIC(19.1,"B",BMXKEY)) S BMXY=0 Q
S BMXIEN=$O(^DIC(19.1,"B",BMXKEY,0))
I '+BMXIEN S BMXY=0 Q
I '$D(^VA(200,DUZ,51,BMXIEN,0)) S BMXY=0 Q
S BMXY=-1
Q
;
SIGCHK(BMXY,BMXSIG) ;EP
;Checks BMXSIG against hashed value in NEW PERSON
;Return IHSCD_SUCCEEDED (-1) if BMXSIG matches
;Otherwise, returns IHSCD_FAILED (0)
N X
S BMXY=0
I '$G(DUZ) Q
I '$D(^VA(200,DUZ,20)) Q ;TODO What if no signature?
S BMXHSH=$P(^VA(200,DUZ,20),U,4)
S X=$G(BMXSIG)
D HASH^XUSHSHP
I X=BMXHSH S BMXY=-1
Q
BMXRPC3 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ; 23 Jul 2009 3:03 PM
+1 ;;4.0;BMX;;JUN 28, 2010
+2 ;
+3 ;
VARVAL(RESULT,VARIABLE) ;returns value of passed in variable
+1 SET VARIABLE=$TRANSLATE(VARIABLE,"~","^")
+2 ;can do this with the REFERENCE type parameter
SET RESULT=VARIABLE
+3 QUIT
+4 ;See GETV^XWBBRK for how we get the REFERENCE type parameter
+5 ;
USER(RESULT,D) ;
+1 ;
+2 IF '+D
SET RESULT=""
QUIT
+3 SET RESULT=$PIECE($GET(^VA(200,D,0)),"^")
+4 QUIT
+5 ;
NTUSER(BMXY,BMXNTUSE) ;EP
+1 ;Old code. Retain for reference
+2 ;Returns NTDomain^NTUserName^RPMSName for user having DUZ=D
+3 ;TODO: Move ANMC NT USERS file
+4 ;from AZZWNT to BMX namespace and numberspace
+5 ;
+6 ;N BMX,BMXNOD,BMXDOM,BMXNAM,BMXCOL,BMXRNAM
+7 ;S (BMXDOM,BMXNAM,BMXRNAM)=""
+8 ;S U="^"
+9 ;I '+D S RESULT="" Q
+10 ;S BMXRNAM=$G(^VA(200,D,0)),BMXRNAM=$P(BMXRNAM,U)
+11 ;I '$D(^AZZWNT("DUZ",D)) D NTU1 Q
+12 ;S BMX=$O(^AZZWNT("DUZ",D,0))
+13 ;I '+BMX D NTU1 Q
+14 ;I '$D(^AZZWNT(BMX,0)) D NTU1 Q
+15 ;S BMXNOD=^AZZWNT(BMX,0)
+16 ;S BMXDOM=$P(BMXNOD,U,2)
+17 ;S BMXNAM=$P(BMXNOD,U) ;,4)
+18 ;D NTU1
+19 QUIT
+20 ;
+21 ;
NTUGETD(BMXY,BMXNTNAM) ;EP
+1 ;Entry point for debugging
+2 ;
+3 ;D DEBUG^%Serenji("NTUGETD^BMXRPC3(.BMXY,BMXNTNAM)")
+4 QUIT
+5 ;
NTUGET(BMXY,BMXNTNAM) ;EP
+1 ;
+2 ;Returns A ENCRYPTED and V ENCRYPTED for NT User BMXNTNM
+3 ;Called by RPC BMXNetGetCodes
+4 NEW BMXI,BMXNTID,BMXNTID,BMXNOD,BMXA,BMXV
+5 SET BMXI=0
+6 SET BMXY="^BMXTMP("_$JOB_")"
+7 SET X="NTUET^BMXRPC3"
SET @^%ZOSF("TRAP")
+8 SET BMXI=BMXI+1
+9 IF BMXNTNM=""
SET ^BMXTMP($JOB,BMXI)="^"
QUIT
+10 SET BMXNTID=$ORDER(^BMXUSER("B",BMXNTNAM,0))
+11 IF '+BMXNTID
SET ^BMXTMP($JOB,BMXI)="^"
QUIT
+12 SET BMXNOD=$GET(^BMXUSER(BMXNTID,0))
+13 SET BMXA=$PIECE(BMXNOD,U,2)
+14 SET BMXV=$PIECE(BMXNOD,U,3)
+15 SET ^BMXTMP($JOB,BMXI)=BMXA_"^"_BMXV_"^"
+16 QUIT
+17 ;
WINUGET(BMXWINID) ;EP
+1 ;Returns DUZ for user having Windows Identity BMXWINID
+2 ;Returns 0 if no Windows user found
+3 ;
+4 NEW BMXIEN,BMXNOD,BMXDUZ
+5 IF BMXWINID=""
QUIT 0
+6 SET BMXIEN=$ORDER(^BMXUSER("B",BMXWINID,0))
+7 IF '+BMXIEN
QUIT 0
+8 SET BMXNOD=$GET(^BMXUSER(BMXIEN,0))
+9 SET BMXDUZ=$PIECE(BMXNOD,U,2)
+10 QUIT BMXDUZ
+11 ;
NTUSET(BMXY,BMXNTNAM) ;EP
+1 ;Sets NEW PERSON map entry for Windows Identity BMXNTNM
+2 ;Returns ERRORID 0 if all ok
+3 ;Called by RPC BMXNetSetUser
+4 ;
+5 ;
+6 NEW BMXI,BMXNTID,BMXFDA,BMXF,BMXIEN,BMXMSG,BMXAPPTD
+7 SET BMXI=0
+8 SET BMXY="^BMXTMP("_$JOB_")"
+9 SET X="NTUET^BMXRPC3"
SET @^%ZOSF("TRAP")
+10 SET BMXI=BMXI+1
+11 ; Quit with error if no DUZ exists
+12 IF '+$GET(DUZ)
DO NTUERR(BMXI,500)
QUIT
+13 ; Create entry or file in existing entry in BMX USER
+14 IF $DATA(^BMXUSER("B",BMXNTNAM))
SET BMXF="?1,"
+15 IF '$TEST
SET BMXF="+1,"
+16 SET BMXFDA(90093.1,BMXF,.01)=BMXNTNAM
+17 SET BMXFDA(90093.1,BMXF,.02)=$GET(DUZ)
+18 KILL BMXIEN,BMXMSG
+19 DO UPDATE^DIE("","BMXFDA","BMXIEN","BMXMSG")
+20 SET BMXAPPTD=+$GET(BMXIEN(1))
+21 SET BMXI=BMXI+1
+22 SET ^BMXTMP($JOB,BMXI)=BMXAPPTD_"^0"
+23 QUIT
+24 ;
NTUET ;EP
+1 ;Error trap from REGEVNT
+2 ;
+3 IF '$DATA(BMXI)
NEW BMXI
SET BMXI=999
+4 SET BMXI=BMXI+1
+5 DO NTUERR(BMXI,99)
+6 QUIT
+7 ;
NTUERR(BMXI,BMXERID) ;Error processing
+1 SET BMXI=BMXI+1
+2 SET ^BMXTMP($JOB,BMXI)="^"_BMXERID
+3 QUIT
+4 ;
+5 ;
NTU1 ;S BMXCOL="T00030NT_DOMAIN^T00030NT_USERNAME^T00030RPMS_USERNAME"_$C(30)
+1 ;S RESULT=BMXCOL_BMXDOM_U_BMXNAM_U_BMXRNAM_$C(30)_$C(31)
+2 QUIT
+3 ;
GETFC(BMXFACS,DUZ) ;Gets all facilities for a user
+1 ; Input DUZ - user IEN from the NEW PERSON FILE
+2 ; Output - Number of facilities;facility1 name&facility1 IEN;...facilityN&facilityN IEN
+3 NEW BMXFN,BMXN
+4 SET BMXFN=0
SET BMXFACS=""
+5 FOR BMXN=1:1
SET BMXFN=$ORDER(^VA(200,DUZ,2,BMXFN))
IF BMXFN=""
QUIT
Begin DoDot:1
+6 IF BMXN>1
SET BMXFACS=BMXFACS_";"
SET BMXFACS=BMXFACS_$PIECE(^DIC(4,BMXFN,0),U,1)_"&"_BMXFN
End DoDot:1
+7 IF BMXN=1
SET BMXFN=$PIECE(^AUTTSITE(1,0),U,1)
Begin DoDot:1
+8 SET BMXFACS=BMXFACS_$PIECE(^DIC(4,BMXFN,0),U,1)_"&"_BMXFN
End DoDot:1
+9 SET BMXFACS=BMXN-(BMXN>1)_";"_BMXFACS
+10 QUIT
+11 ;
GETFCRS(BMXFACS,BMXDUZ) ;Gets all facilities for a user - returns RECORDSET
+1 ;
+2 ;TODO: return as global array, add error checking
+3 NEW BMXFN,BMXN,BMXSUB,BMXRCNT
+4 SET BMXDUZ=$TRANSLATE(BMXDUZ,$CHAR(13),"")
+5 SET BMXDUZ=$TRANSLATE(BMXDUZ,$CHAR(10),"")
+6 SET BMXDUZ=$TRANSLATE(BMXDUZ,$CHAR(9),"")
+7 SET BMXFN=0
+8 SET BMXSUB="^VA(200,"_BMXDUZ_",2,"
+9 SET BMXFACS="T00030FACILITY_NAME^T00030FACILITY_IEN^T00002MOST_RECENT_LOOKUP"_$CHAR(30)
+10 ;F BMXN=1:1 S BMXFN=$O(^VA(200,BMXDUZ,2,BMXFN)) Q:BMXFN="" D
+11 ;cmi/maw mod 10/17/2006
SET BMXRCNT=0
+12 ;IHS/ANMC/LJF 8/9/01
FOR BMXN=1:1
SET BMXFN=$ORDER(^VA(200,BMXDUZ,2,BMXFN))
IF 'BMXFN
QUIT
Begin DoDot:1
+13 ;S BMXFACS=BMXFACS_$P(^DIC(4,BMXFN,0),U,1)_"^"_BMXFN_$C(30)
+14 SET BMXFACS=BMXFACS_$PIECE(^DIC(4,BMXFN,0),U,1)_"^"_BMXFN
+15 ;S BMXRCNT=0 ;cmi/maw orig
+16 ;I $D(^DISV(BMXDUZ,BMXSUB)),^DISV(BMXDUZ,BMXSUB)=BMXFN S BMXRCNT=1
+17 ;I $G(DUZ(2))=BMXFN S BMXRCNT=1 ;cmi/maw orig
+18 ;cmi/maw mod
SET BMXRCNT=BMXRCNT+1
+19 SET BMXFACS=BMXFACS_"^"_BMXRCNT_$CHAR(30)
End DoDot:1
+20 IF BMXN=1
SET BMXFN=$PIECE(^AUTTSITE(1,0),U,1)
Begin DoDot:1
+21 SET BMXFACS=BMXFACS_$PIECE(^DIC(4,BMXFN,0),U,1)_"^"_BMXFN_"^"_1_$CHAR(30)
End DoDot:1
+22 SET BMXFACS=BMXFACS_$CHAR(31)
+23 QUIT
+24 ;
SETFCRS(BMXY,BMXFAC) ;
+1 ;
+2 ;Sets DUZ(2) to value in BMXFAC
+3 ;Fails if BMXFAC is not one of the current user's divisions
+4 ;Returns Recordset
+5 ;
+6 SET X="ERFC^BMXRPC3"
SET @^%ZOSF("TRAP")
+7 SET BMXY="T00030DUZ^T00030FACILITY_IEN^T00030FACILITY_NAME"_$CHAR(30)
+8 NEW BMXSUB,BMXFACN
+9 IF '+DUZ
SET BMXY=BMXY_0_"^"_0_"^"_0_$CHAR(30)_$CHAR(31)
QUIT
+10 IF '+BMXFAC
SET BMXY=BMXY_DUZ_"^"_0_"^"_0_$CHAR(30)_$CHAR(31)
QUIT
+11 ;I '$D(^VA(200,DUZ,2,+BMXFAC,0)) S BMXY=BMXY_DUZ_"^"_0_"^"_0_$C(30)_$C(31) Q ; GIS/OIT Feb 9, 2010
+12 ;IHS/OIT/HMW SAC Exemption Applied For
SET DUZ(2)=BMXFAC
+13 SET BMXFACN=$GET(^DIC(4,+DUZ(2),0))
+14 SET BMXFACN=$PIECE(BMXFACN,"^")
+15 SET BMXSUB="^VA(200,"_DUZ_",2,"
+16 SET ^DISV(DUZ,BMXSUB)=BMXFAC
+17 SET BMXY=BMXY_DUZ_"^"_BMXFAC_"^"_BMXFACN_$CHAR(30)_$CHAR(31)
+18 QUIT
+19 ;
ERFC ;
+1 DO ^%ZTER
+2 SET BMXY=$GET(BMXY)_0_"^"_0_$CHAR(30)_$CHAR(31)
QUIT
+3 QUIT
+4 ;
SETFC(BMXY,BMXFAC) ;
+1 ;Sets DUZ(2) to value in BMXFAC
+2 ;Fails if BMXFAC is not one of the current user's divisions
+3 ;Returns 1 if successful, 0 if failed
+4 ;
+5 SET BMXY=0
+6 NEW BMXSUB
+7 IF '+DUZ
SET BMXY=0
QUIT
+8 IF '+BMXFAC
SET BMXY=0
QUIT
+9 IF '$DATA(^VA(200,DUZ,2,+BMXFAC,0))
SET BMXY=0
QUIT
+10 ;IHS/OIT/HMW SAC Exemption Applied For
SET DUZ(2)=BMXFAC
+11 SET BMXSUB="^VA(200,"_DUZ_",2,"
+12 SET ^DISV(DUZ,BMXSUB)=BMXFAC
+13 SET BMXY=1
+14 QUIT
+15 ;
APSEC(BMXY,BMXKEY) ;EP
+1 ;Return IHSCD_SUCCEEDED (-1) if user has key BMXKEY
+2 ;OR if user has key XUPROGMODE
+3 ;Otherwise, returns IHSCD_FAILED (0)
+4 NEW BMXIEN,BMXPROG,BMXPKEY
+5 IF '$GET(DUZ)
SET BMXY=0
QUIT
+6 IF BMXKEY=""
SET BMXY=0
QUIT
+7 ;
+8 ;Test for programmer mode key
+9 SET BMXPROG=0
+10 IF $DATA(^DIC(19.1,"B","XUPROGMODE"))
Begin DoDot:1
+11 SET BMXPKEY=$ORDER(^DIC(19.1,"B","XUPROGMODE",0))
+12 IF '+BMXPKEY
QUIT
+13 IF '$DATA(^VA(200,DUZ,51,BMXPKEY,0))
QUIT
+14 SET BMXPROG=1
End DoDot:1
+15 IF BMXPROG
SET BMXY=-1
QUIT
+16 ;
+17 IF '$DATA(^DIC(19.1,"B",BMXKEY))
SET BMXY=0
QUIT
+18 SET BMXIEN=$ORDER(^DIC(19.1,"B",BMXKEY,0))
+19 IF '+BMXIEN
SET BMXY=0
QUIT
+20 IF '$DATA(^VA(200,DUZ,51,BMXIEN,0))
SET BMXY=0
QUIT
+21 SET BMXY=-1
+22 QUIT
+23 ;
SIGCHK(BMXY,BMXSIG) ;EP
+1 ;Checks BMXSIG against hashed value in NEW PERSON
+2 ;Return IHSCD_SUCCEEDED (-1) if BMXSIG matches
+3 ;Otherwise, returns IHSCD_FAILED (0)
+4 NEW X
+5 SET BMXY=0
+6 IF '$GET(DUZ)
QUIT
+7 ;TODO What if no signature?
IF '$DATA(^VA(200,DUZ,20))
QUIT
+8 SET BMXHSH=$PIECE(^VA(200,DUZ,20),U,4)
+9 SET X=$GET(BMXSIG)
+10 DO HASH^XUSHSHP
+11 IF X=BMXHSH
SET BMXY=-1
+12 QUIT
