BIKEY1 ;IHS/CMI/MWR - ALLOCATE/DEALLOCATE BI KEYS; MAY 10, 2010
;;8.5;IMMUNIZATION;;SEP 01,2011
;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
;; ALLOCATE/DEALLOCATE BI KEYS TO USERS.
;
;
;----------
START ;EP
;
;---> If DUZ is undefined or User does not hold BIZ MANAGER Key, quit.
D SETVARS^BIUTL5
D FULL^VALM1
I '$G(DUZ) D TITLE,ERRCD^BIUTL2(106,,1),RESET^BIKEY Q
I '$D(^XUSEC("BIZ MANAGER",DUZ)) D Q
.D TITLE,ERRCD^BIUTL2(631,,1),RESET^BIKEY Q
;
;---> Select Person/User loop.
N Y
F D Q:Y<0
.D TITLE
.W !!?5,"Select the Person to whom you wish to Allocate or Deallocate"
.W !?5,"an Immunization (BIZ) Key.",!
.D DIC^BIFMAN(200,"QEMA",.Y," Select PERSON: ")
.Q:Y<0
.D SELECT(+Y)
D RESET^BIKEY
Q
;
;
;----------
SELECT(BIDUZ) ;EP
;---> Select Key and action.
;---> Parameters:
; 1 - BIDUZ (req) Person's IEN in New Person File #200.
;
I '$G(BIDUZ) S BIERR=106 Q
I '$D(^VA(200,BIDUZ,0)) S BIERR=112 Q
;
;---> Allocate or Deallocate.
N BIHOLDER S BIHOLDER=$$PERSON^BIUTL1(BIDUZ,1)
W !!?5,"Do you wish to Allocate or Deallocate the Keys to "
W BIHOLDER,"?"
N DIR
S DIR("?",1)=" Choose Allocate to give a Key to a user."
S DIR("?")=" Choose Deallocate to take away a Key from a user."
S DIR(0)="SOM^A:Allocate;D:Deallocate"
S DIR("A")=" Enter A or D"
D ^DIR K DIR W !
I $D(DIRUT) D NOCHANGE Q
;---> BIALL=1=Allocate, BIALL=0=Deallocate.
N BIALL S BIALL=$S(Y="A":1,1:0)
;
;---> Select Key.
D TITLE
W !!?5,"Select the Key(s) you wish to "
W:'BIALL "DE" W "ALLOCATE ",$S(BIALL:"to ",1:"from "),BIHOLDER,":"
D @$S(BIALL:"TEXT1",1:"TEXT2"),TEXT3
;
N DIR
S DIR("?")="^D HELP1^BIKEY1"
S DIR(0)="LAO^1:4"
S DIR("A")=" Enter 1, 2, 3, or 4: "
D ^DIR W !
I Y<1!($D(DIRUT)) D NOCHANGE Q
K DIR N BIKEYS,BIPL,I S BIPL=0
;
;---> If Manager Key selected, automatically allocate all Keys.
I BIALL,Y[3 S Y="1,2,3"
F I=1,2,3,4 I Y[I S BIKEYS(I)="",BIPL=BIPL+1
I '$D(BIKEYS) D NOCHANGE Q
;
;
;---> Confirm.
D TITLE
W !!?5 W:'BIALL "DE" W "ALLOCATE the Key" W:(BIPL>1) "s" W ":",!
W:$D(BIKEYS(1)) !?10,"1 - BIZMENU"
W:$D(BIKEYS(2)) !?10,"2 - BIZ EDIT PATIENTS"
W:$D(BIKEYS(3)) !?10,"3 - BIZ MANAGER"
W:$D(BIKEYS(4)) !?10,"4 - BIZ LOT ONLY"
;
W !!?5,$S(BIALL:"To ",1:"From "),$$PERSON^BIUTL1(BIDUZ,1),"?",!
;
N B S B(1)=" Enter YES to "_$S('BIALL:"DE",1:"")
S B(1)=B(1)_"ALLOCATE the Key"_$S(BIPL>1:"s ",1:" ")
S B(1)=B(1)_$S(BIALL:"to ",1:"from ")_$$PERSON^BIUTL1(BIDUZ,1)_"."
S B(2)=" Enter NO to make no changes."
D DIR^BIFMAN("Y",.Y,," Enter Yes or No","NO",B(2),B(1))
;
;---> Failed to confirm.
I Y<1!($D(DIRUT)) D NOCHANGE Q
;
;---> Allocate/Deallocate.
N BIERR
F I=1,2,3,4 D:$D(BIKEYS(I))
.D ALLOC(BIDUZ,I,BIALL,.BIERR)
.I $G(BIERR) D ERRCD^BIUTL2(BIERR,,1) Q
;
I '$G(BIERR) W !!?5,"Done." D DIRZ^BIUTL3()
Q
;
;
;----------
HELP1 ;EP
D TEXT4,DIRZ^BIUTL3()
D TITLE
W !!?5,"Select the Key(s) you wish to "
W:'BIALL "DE" W "ALLOCATE to ",BIHOLDER,":"
D @$S(BIALL:"TEXT1",1:"TEXT2"),TEXT3
Q
;
;
;----------
TEXT1 ;EP
;;
;;Enter the number of the Key you wish to allocate. To select more
;;than one key, enter the numbers separated by commas. For example,
;;entering 1,2 will select the first two Keys.
;;
;;(NOTE: If you select Key #3, BIZ MANAGER, then the Keys BIZMENU and
;; BIZ EDIT PATIENTS will be allocated automatically.)
;;
D PRINTX("TEXT1")
Q
;
;
;----------
TEXT2 ;EP
;;
;;Enter the number of the Key you wish to deallocate. To select more
;;than one key, enter the numbers separated by commas. For example,
;;entering 1,2 will select the first two Keys.
;;
D PRINTX("TEXT2")
Q
;
;
;----------
TEXT3 ;EP
;;
;;1 - BIZMENU
;;2 - BIZ EDIT PATIENTS
;;3 - BIZ MANAGER
;;4 - BIZ LOT ONLY
;;
D PRINTX("TEXT3",10)
Q
;
;
;----------
TEXT4 ;EP
;;
;; Enter 1 for BIZMENU, or 2 for BIZ EDIT PATIENTS, 3 for BIZ MANAGER
;; MANAGER, or 4 for BIZ LOT ONLY.
;; Or enter any combination of 1, 2 and 3 using commas.
;;
;;* For a more complete explanation of the Keys and the privileges
;; they confer, return to the first screen listing Holders of Keys
;; and choose the Action "H Help".
;;
D PRINTX("TEXT4",8)
Q
;
;
;----------
ALLOC(BIDUZ,BIKEY,BIALL,BIERR) ;EP
;---> Allocate BIZ Key to a Person.
;---> Parameters:
; 1 - BIDUZ (req) Person's IEN in New Person File #200.
; 2 - BIKEY (req) Number of Key (1,2,or3).
; 3 - BIALL (req) 0=Deallocate, 1=Allocate.
; 4 - BIERR (ret) Text of any error returned.
;
;
I '$G(BIDUZ) S BIERR=106 Q
I '$D(^VA(200,BIDUZ,0)) S BIERR=112 Q
;
;---> Quit if Key not provided.
I '$G(BIKEY) S BIERR=635 Q
;
N BIKEYNM
D
.I BIKEY=1 S BIKEYNM="BIZMENU" Q
.I BIKEY=2 S BIKEYNM="BIZ EDIT PATIENTS" Q
.I BIKEY=3 S BIKEYNM="BIZ MANAGER" Q
.I BIKEY=4 S BIKEYNM="BIZ LOT ONLY"
I $G(BIKEYNM)="" S BIERR=635 Q
;
;---> Set BIKIEN=Key IEN.
N BIKIEN S BIKIEN=$O(^DIC(19.1,"B",BIKEYNM,0))
;---> Quit if Key does not exist.
I 'BIKIEN S BIERR=632 Q
;---> Quit if there are duplicate keys.
I $O(^DIC(19.1,"B",BIKEY,BIKIEN)) S BIERR=633 Q
;
;---> Quit if BIALL not specified.
I ($G(BIALL)'=0)&($G(BIALL)'=1) S BIERR=634 Q
;
;---> Deallocate, quit.
I BIALL=0 D Q
.N DIK,DA S DIK="^VA(200,"_BIDUZ_",51,",DA(1)=BIDUZ,DA=BIKIEN
.D ^DIK
;
;---> Allocate.
Q:$D(^XUSEC(BIKEYNM,BIDUZ)) ;already has new key
N DIC,DD,DO K DO
S DIC(0)="NMQ",DIC("P")="200.051PA"
S DIC="^VA(200,"_BIDUZ_",51,",DA(1)=BIDUZ,X=BIKIEN,DINUM=X
D FILE^DICN
I Y<0 S BIERR=636
K DIC,DINUM,DA
Q
;
;
;----------
TITLE ;EP
;---> Clear screen and write title.
D TITLE^BIUTL5("ALLOCATE/DEALLOCATE IMM KEYS")
Q
;
;
;----------
NOCHANGE ;EP
W !!?5,"NO changes made." D DIRZ^BIUTL3()
Q
;
;
;----------
PRINTX(BILINL,BITAB) ;EP
Q:$G(BILINL)=""
N I,T,X S T="" S:'$D(BITAB) BITAB=5 F I=1:1:BITAB S T=T_" "
F I=1:1 S X=$T(@BILINL+I) Q:X'[";;" W !,T,$P(X,";;",2)
Q
BIKEY1 ;IHS/CMI/MWR - ALLOCATE/DEALLOCATE BI KEYS; MAY 10, 2010
+1 ;;8.5;IMMUNIZATION;;SEP 01,2011
+2 ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
+3 ;; ALLOCATE/DEALLOCATE BI KEYS TO USERS.
+4 ;
+5 ;
+6 ;----------
START ;EP
+1 ;
+2 ;---> If DUZ is undefined or User does not hold BIZ MANAGER Key, quit.
+3 DO SETVARS^BIUTL5
+4 DO FULL^VALM1
+5 IF '$GET(DUZ)
DO TITLE
DO ERRCD^BIUTL2(106,,1)
DO RESET^BIKEY
QUIT
+6 IF '$DATA(^XUSEC("BIZ MANAGER",DUZ))
Begin DoDot:1
+7 DO TITLE
DO ERRCD^BIUTL2(631,,1)
DO RESET^BIKEY
QUIT
End DoDot:1
QUIT
+8 ;
+9 ;---> Select Person/User loop.
+10 NEW Y
+11 FOR
Begin DoDot:1
+12 DO TITLE
+13 WRITE !!?5,"Select the Person to whom you wish to Allocate or Deallocate"
+14 WRITE !?5,"an Immunization (BIZ) Key.",!
+15 DO DIC^BIFMAN(200,"QEMA",.Y," Select PERSON: ")
+16 IF Y<0
QUIT
+17 DO SELECT(+Y)
End DoDot:1
IF Y<0
QUIT
+18 DO RESET^BIKEY
+19 QUIT
+20 ;
+21 ;
+22 ;----------
SELECT(BIDUZ) ;EP
+1 ;---> Select Key and action.
+2 ;---> Parameters:
+3 ; 1 - BIDUZ (req) Person's IEN in New Person File #200.
+4 ;
+5 IF '$GET(BIDUZ)
SET BIERR=106
QUIT
+6 IF '$DATA(^VA(200,BIDUZ,0))
SET BIERR=112
QUIT
+7 ;
+8 ;---> Allocate or Deallocate.
+9 NEW BIHOLDER
SET BIHOLDER=$$PERSON^BIUTL1(BIDUZ,1)
+10 WRITE !!?5,"Do you wish to Allocate or Deallocate the Keys to "
+11 WRITE BIHOLDER,"?"
+12 NEW DIR
+13 SET DIR("?",1)=" Choose Allocate to give a Key to a user."
+14 SET DIR("?")=" Choose Deallocate to take away a Key from a user."
+15 SET DIR(0)="SOM^A:Allocate;D:Deallocate"
+16 SET DIR("A")=" Enter A or D"
+17 DO ^DIR
KILL DIR
WRITE !
+18 IF $DATA(DIRUT)
DO NOCHANGE
QUIT
+19 ;---> BIALL=1=Allocate, BIALL=0=Deallocate.
+20 NEW BIALL
SET BIALL=$SELECT(Y="A":1,1:0)
+21 ;
+22 ;---> Select Key.
+23 DO TITLE
+24 WRITE !!?5,"Select the Key(s) you wish to "
+25 IF 'BIALL
WRITE "DE"
WRITE "ALLOCATE ",$SELECT(BIALL:"to ",1:"from "),BIHOLDER,":"
+26 DO @$SELECT(BIALL:"TEXT1",1:"TEXT2")
DO TEXT3
+27 ;
+28 NEW DIR
+29 SET DIR("?")="^D HELP1^BIKEY1"
+30 SET DIR(0)="LAO^1:4"
+31 SET DIR("A")=" Enter 1, 2, 3, or 4: "
+32 DO ^DIR
WRITE !
+33 IF Y<1!($DATA(DIRUT))
DO NOCHANGE
QUIT
+34 KILL DIR
NEW BIKEYS,BIPL,I
SET BIPL=0
+35 ;
+36 ;---> If Manager Key selected, automatically allocate all Keys.
+37 IF BIALL
IF Y[3
SET Y="1,2,3"
+38 FOR I=1,2,3,4
IF Y[I
SET BIKEYS(I)=""
SET BIPL=BIPL+1
+39 IF '$DATA(BIKEYS)
DO NOCHANGE
QUIT
+40 ;
+41 ;
+42 ;---> Confirm.
+43 DO TITLE
+44 WRITE !!?5
IF 'BIALL
WRITE "DE"
WRITE "ALLOCATE the Key"
IF (BIPL>1)
WRITE "s"
WRITE ":",!
+45 IF $DATA(BIKEYS(1))
WRITE !?10,"1 - BIZMENU"
+46 IF $DATA(BIKEYS(2))
WRITE !?10,"2 - BIZ EDIT PATIENTS"
+47 IF $DATA(BIKEYS(3))
WRITE !?10,"3 - BIZ MANAGER"
+48 IF $DATA(BIKEYS(4))
WRITE !?10,"4 - BIZ LOT ONLY"
+49 ;
+50 WRITE !!?5,$SELECT(BIALL:"To ",1:"From "),$$PERSON^BIUTL1(BIDUZ,1),"?",!
+51 ;
+52 NEW B
SET B(1)=" Enter YES to "_$SELECT('BIALL:"DE",1:"")
+53 SET B(1)=B(1)_"ALLOCATE the Key"_$SELECT(BIPL>1:"s ",1:" ")
+54 SET B(1)=B(1)_$SELECT(BIALL:"to ",1:"from ")_$$PERSON^BIUTL1(BIDUZ,1)_"."
+55 SET B(2)=" Enter NO to make no changes."
+56 DO DIR^BIFMAN("Y",.Y,," Enter Yes or No","NO",B(2),B(1))
+57 ;
+58 ;---> Failed to confirm.
+59 IF Y<1!($DATA(DIRUT))
DO NOCHANGE
QUIT
+60 ;
+61 ;---> Allocate/Deallocate.
+62 NEW BIERR
+63 FOR I=1,2,3,4
IF $DATA(BIKEYS(I))
Begin DoDot:1
+64 DO ALLOC(BIDUZ,I,BIALL,.BIERR)
+65 IF $GET(BIERR)
DO ERRCD^BIUTL2(BIERR,,1)
QUIT
End DoDot:1
+66 ;
+67 IF '$GET(BIERR)
WRITE !!?5,"Done."
DO DIRZ^BIUTL3()
+68 QUIT
+69 ;
+70 ;
+71 ;----------
HELP1 ;EP
+1 DO TEXT4
DO DIRZ^BIUTL3()
+2 DO TITLE
+3 WRITE !!?5,"Select the Key(s) you wish to "
+4 IF 'BIALL
WRITE "DE"
WRITE "ALLOCATE to ",BIHOLDER,":"
+5 DO @$SELECT(BIALL:"TEXT1",1:"TEXT2")
DO TEXT3
+6 QUIT
+7 ;
+8 ;
+9 ;----------
TEXT1 ;EP
+1 ;;
+2 ;;Enter the number of the Key you wish to allocate. To select more
+3 ;;than one key, enter the numbers separated by commas. For example,
+4 ;;entering 1,2 will select the first two Keys.
+5 ;;
+6 ;;(NOTE: If you select Key #3, BIZ MANAGER, then the Keys BIZMENU and
+7 ;; BIZ EDIT PATIENTS will be allocated automatically.)
+8 ;;
+9 DO PRINTX("TEXT1")
+10 QUIT
+11 ;
+12 ;
+13 ;----------
TEXT2 ;EP
+1 ;;
+2 ;;Enter the number of the Key you wish to deallocate. To select more
+3 ;;than one key, enter the numbers separated by commas. For example,
+4 ;;entering 1,2 will select the first two Keys.
+5 ;;
+6 DO PRINTX("TEXT2")
+7 QUIT
+8 ;
+9 ;
+10 ;----------
TEXT3 ;EP
+1 ;;
+2 ;;1 - BIZMENU
+3 ;;2 - BIZ EDIT PATIENTS
+4 ;;3 - BIZ MANAGER
+5 ;;4 - BIZ LOT ONLY
+6 ;;
+7 DO PRINTX("TEXT3",10)
+8 QUIT
+9 ;
+10 ;
+11 ;----------
TEXT4 ;EP
+1 ;;
+2 ;; Enter 1 for BIZMENU, or 2 for BIZ EDIT PATIENTS, 3 for BIZ MANAGER
+3 ;; MANAGER, or 4 for BIZ LOT ONLY.
+4 ;; Or enter any combination of 1, 2 and 3 using commas.
+5 ;;
+6 ;;* For a more complete explanation of the Keys and the privileges
+7 ;; they confer, return to the first screen listing Holders of Keys
+8 ;; and choose the Action "H Help".
+9 ;;
+10 DO PRINTX("TEXT4",8)
+11 QUIT
+12 ;
+13 ;
+14 ;----------
ALLOC(BIDUZ,BIKEY,BIALL,BIERR) ;EP
+1 ;---> Allocate BIZ Key to a Person.
+2 ;---> Parameters:
+3 ; 1 - BIDUZ (req) Person's IEN in New Person File #200.
+4 ; 2 - BIKEY (req) Number of Key (1,2,or3).
+5 ; 3 - BIALL (req) 0=Deallocate, 1=Allocate.
+6 ; 4 - BIERR (ret) Text of any error returned.
+7 ;
+8 ;
+9 IF '$GET(BIDUZ)
SET BIERR=106
QUIT
+10 IF '$DATA(^VA(200,BIDUZ,0))
SET BIERR=112
QUIT
+11 ;
+12 ;---> Quit if Key not provided.
+13 IF '$GET(BIKEY)
SET BIERR=635
QUIT
+14 ;
+15 NEW BIKEYNM
+16 Begin DoDot:1
+17 IF BIKEY=1
SET BIKEYNM="BIZMENU"
QUIT
+18 IF BIKEY=2
SET BIKEYNM="BIZ EDIT PATIENTS"
QUIT
+19 IF BIKEY=3
SET BIKEYNM="BIZ MANAGER"
QUIT
+20 IF BIKEY=4
SET BIKEYNM="BIZ LOT ONLY"
End DoDot:1
+21 IF $GET(BIKEYNM)=""
SET BIERR=635
QUIT
+22 ;
+23 ;---> Set BIKIEN=Key IEN.
+24 NEW BIKIEN
SET BIKIEN=$ORDER(^DIC(19.1,"B",BIKEYNM,0))
+25 ;---> Quit if Key does not exist.
+26 IF 'BIKIEN
SET BIERR=632
QUIT
+27 ;---> Quit if there are duplicate keys.
+28 IF $ORDER(^DIC(19.1,"B",BIKEY,BIKIEN))
SET BIERR=633
QUIT
+29 ;
+30 ;---> Quit if BIALL not specified.
+31 IF ($GET(BIALL)'=0)&($GET(BIALL)'=1)
SET BIERR=634
QUIT
+32 ;
+33 ;---> Deallocate, quit.
+34 IF BIALL=0
Begin DoDot:1
+35 NEW DIK,DA
SET DIK="^VA(200,"_BIDUZ_",51,"
SET DA(1)=BIDUZ
SET DA=BIKIEN
+36 DO ^DIK
End DoDot:1
QUIT
+37 ;
+38 ;---> Allocate.
+39 ;already has new key
IF $DATA(^XUSEC(BIKEYNM,BIDUZ))
QUIT
+40 NEW DIC,DD,DO
KILL DO
+41 SET DIC(0)="NMQ"
SET DIC("P")="200.051PA"
+42 SET DIC="^VA(200,"_BIDUZ_",51,"
SET DA(1)=BIDUZ
SET X=BIKIEN
SET DINUM=X
+43 DO FILE^DICN
+44 IF Y<0
SET BIERR=636
+45 KILL DIC,DINUM,DA
+46 QUIT
+47 ;
+48 ;
+49 ;----------
TITLE ;EP
+1 ;---> Clear screen and write title.
+2 DO TITLE^BIUTL5("ALLOCATE/DEALLOCATE IMM KEYS")
+3 QUIT
+4 ;
+5 ;
+6 ;----------
NOCHANGE ;EP
+1 WRITE !!?5,"NO changes made."
DO DIRZ^BIUTL3()
+2 QUIT
+3 ;
+4 ;
+5 ;----------
PRINTX(BILINL,BITAB) ;EP
+1 IF $GET(BILINL)=""
QUIT
+2 NEW I,T,X
SET T=""
IF '$DATA(BITAB)
SET BITAB=5
FOR I=1:1:BITAB
SET T=T_" "
+3 FOR I=1:1
SET X=$TEXT(@BILINL+I)
IF X'[";;"
QUIT
WRITE !,T,$PIECE(X,";;",2)
+4 QUIT
