Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BIKEY1

BIKEY1.m

Go to the documentation of this file. 
  1. BIKEY1 ;IHS/CMI/MWR - ALLOCATE/DEALLOCATE BI KEYS; MAY 10, 2010
  1.  ;;8.5;IMMUNIZATION;;SEP 01,2011
  1.  ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
  1.  ;;  ALLOCATE/DEALLOCATE BI KEYS TO USERS.
  1.  ;
  1.  ;
  1.  ;----------
  1. START ;EP
  1.  ;
  1.  ;---> If DUZ is undefined or User does not hold BIZ MANAGER Key, quit.
  1.  D SETVARS^BIUTL5
  1.  D FULL^VALM1
  1.  I '$G(DUZ) D TITLE,ERRCD^BIUTL2(106,,1),RESET^BIKEY Q
  1.  I '$D(^XUSEC("BIZ MANAGER",DUZ)) D  Q
  1.  .D TITLE,ERRCD^BIUTL2(631,,1),RESET^BIKEY Q
  1.  ;
  1.  ;---> Select Person/User loop.
  1.  N Y
  1.  F  D  Q:Y<0
  1.  .D TITLE
  1.  .W !!?5,"Select the Person to whom you wish to Allocate or Deallocate"
  1.  .W !?5,"an Immunization (BIZ) Key.",!
  1.  .D DIC^BIFMAN(200,"QEMA",.Y,"     Select PERSON: ")
  1.  .Q:Y<0
  1.  .D SELECT(+Y)
  1.  D RESET^BIKEY
  1.  Q
  1.  ;
  1.  ;
  1.  ;----------
  1. SELECT(BIDUZ) ;EP
  1.  ;---> Select Key and action.
  1.  ;---> Parameters:
  1.  ;     1 - BIDUZ  (req) Person's IEN in New Person File #200.
  1.  ;
  1.  I '$G(BIDUZ) S BIERR=106 Q
  1.  I '$D(^VA(200,BIDUZ,0)) S BIERR=112 Q
  1.  ;
  1.  ;---> Allocate or Deallocate.
  1.  N BIHOLDER S BIHOLDER=$$PERSON^BIUTL1(BIDUZ,1)
  1.  W !!?5,"Do you wish to Allocate or Deallocate the Keys to "
  1.  W BIHOLDER,"?"
  1.  N DIR
  1.  S DIR("?",1)="     Choose Allocate to give a Key to a user."
  1.  S DIR("?")="     Choose Deallocate to take away a Key from a user."
  1.  S DIR(0)="SOM^A:Allocate;D:Deallocate"
  1.  S DIR("A")="     Enter A or D"
  1.  D ^DIR K DIR W !
  1.  I $D(DIRUT) D NOCHANGE Q
  1.  ;---> BIALL=1=Allocate, BIALL=0=Deallocate.
  1.  N BIALL S BIALL=$S(Y="A":1,1:0)
  1.  ;
  1.  ;---> Select Key.
  1.  D TITLE
  1.  W !!?5,"Select the Key(s) you wish to "
  1.  W:'BIALL "DE" W "ALLOCATE ",$S(BIALL:"to ",1:"from "),BIHOLDER,":"
  1.  D @$S(BIALL:"TEXT1",1:"TEXT2"),TEXT3
  1.  ;
  1.  N DIR
  1.  S DIR("?")="^D HELP1^BIKEY1"
  1.  S DIR(0)="LAO^1:4"
  1.  S DIR("A")="     Enter 1, 2, 3, or 4: "
  1.  D ^DIR W !
  1.  I Y<1!($D(DIRUT)) D NOCHANGE Q
  1.  K DIR N BIKEYS,BIPL,I S BIPL=0
  1.  ;
  1.  ;---> If Manager Key selected, automatically allocate all Keys.
  1.  I BIALL,Y[3 S Y="1,2,3"
  1.  F I=1,2,3,4 I Y[I S BIKEYS(I)="",BIPL=BIPL+1
  1.  I '$D(BIKEYS) D NOCHANGE Q
  1.  ;
  1.  ;
  1.  ;---> Confirm.
  1.  D TITLE
  1.  W !!?5 W:'BIALL "DE" W "ALLOCATE the Key" W:(BIPL>1) "s" W ":",!
  1.  W:$D(BIKEYS(1)) !?10,"1 - BIZMENU"
  1.  W:$D(BIKEYS(2)) !?10,"2 - BIZ EDIT PATIENTS"
  1.  W:$D(BIKEYS(3)) !?10,"3 - BIZ MANAGER"
  1.  W:$D(BIKEYS(4)) !?10,"4 - BIZ LOT ONLY"
  1.  ;
  1.  W !!?5,$S(BIALL:"To ",1:"From "),$$PERSON^BIUTL1(BIDUZ,1),"?",!
  1.  ;
  1.  N B S B(1)="     Enter YES to "_$S('BIALL:"DE",1:"")
  1.  S B(1)=B(1)_"ALLOCATE the Key"_$S(BIPL>1:"s ",1:" ")
  1.  S B(1)=B(1)_$S(BIALL:"to ",1:"from ")_$$PERSON^BIUTL1(BIDUZ,1)_"."
  1.  S B(2)="     Enter NO to make no changes."
  1.  D DIR^BIFMAN("Y",.Y,,"     Enter Yes or No","NO",B(2),B(1))
  1.  ;
  1.  ;---> Failed to confirm.
  1.  I Y<1!($D(DIRUT)) D NOCHANGE Q
  1.  ;
  1.  ;---> Allocate/Deallocate.
  1.  N BIERR
  1.  F I=1,2,3,4 D:$D(BIKEYS(I))
  1.  .D ALLOC(BIDUZ,I,BIALL,.BIERR)
  1.  .I $G(BIERR) D ERRCD^BIUTL2(BIERR,,1) Q
  1.  ;
  1.  I '$G(BIERR) W !!?5,"Done." D DIRZ^BIUTL3()
  1.  Q
  1.  ;
  1.  ;
  1.  ;----------
  1. HELP1 ;EP
  1.  D TEXT4,DIRZ^BIUTL3()
  1.  D TITLE
  1.  W !!?5,"Select the Key(s) you wish to "
  1.  W:'BIALL "DE" W "ALLOCATE to ",BIHOLDER,":"
  1.  D @$S(BIALL:"TEXT1",1:"TEXT2"),TEXT3
  1.  Q
  1.  ;
  1.  ;
  1.  ;----------
  1. TEXT1 ;EP
  1.  ;;
  1.  ;;Enter the number of the Key you wish to allocate.  To select more
  1.  ;;than one key, enter the numbers separated by commas.  For example,
  1.  ;;entering 1,2 will select the first two Keys.
  1.  ;;
  1.  ;;(NOTE: If you select Key #3, BIZ MANAGER, then the Keys BIZMENU and
  1.  ;; BIZ EDIT PATIENTS will be allocated automatically.)
  1.  ;;
  1.  D PRINTX("TEXT1")
  1.  Q
  1.  ;
  1.  ;
  1.  ;----------
  1. TEXT2 ;EP
  1.  ;;
  1.  ;;Enter the number of the Key you wish to deallocate.  To select more
  1.  ;;than one key, enter the numbers separated by commas.  For example,
  1.  ;;entering 1,2 will select the first two Keys.
  1.  ;;
  1.  D PRINTX("TEXT2")
  1.  Q
  1.  ;
  1.  ;
  1.  ;----------
  1. TEXT3 ;EP
  1.  ;;
  1.  ;;1 - BIZMENU
  1.  ;;2 - BIZ EDIT PATIENTS
  1.  ;;3 - BIZ MANAGER
  1.  ;;4 - BIZ LOT ONLY
  1.  ;;
  1.  D PRINTX("TEXT3",10)
  1.  Q
  1.  ;
  1.  ;
  1.  ;----------
  1. TEXT4 ;EP
  1.  ;;
  1.  ;;  Enter 1 for BIZMENU, or 2 for BIZ EDIT PATIENTS, 3 for BIZ MANAGER
  1.  ;;  MANAGER, or 4 for BIZ LOT ONLY.
  1.  ;;  Or enter any combination of 1, 2 and 3 using commas.
  1.  ;;
  1.  ;;* For a more complete explanation of the Keys and the privileges
  1.  ;;  they confer, return to the first screen listing Holders of Keys
  1.  ;;  and choose the Action "H Help".
  1.  ;;
  1.  D PRINTX("TEXT4",8)
  1.  Q
  1.  ;
  1.  ;
  1.  ;----------
  1. ALLOC(BIDUZ,BIKEY,BIALL,BIERR) ;EP
  1.  ;---> Allocate BIZ Key to a Person.
  1.  ;---> Parameters:
  1.  ;     1 - BIDUZ  (req) Person's IEN in New Person File #200.
  1.  ;     2 - BIKEY  (req) Number of Key (1,2,or3).
  1.  ;     3 - BIALL  (req) 0=Deallocate, 1=Allocate.
  1.  ;     4 - BIERR  (ret) Text of any error returned.
  1.  ;
  1.  ;
  1.  I '$G(BIDUZ) S BIERR=106 Q
  1.  I '$D(^VA(200,BIDUZ,0)) S BIERR=112 Q
  1.  ;
  1.  ;---> Quit if Key not provided.
  1.  I '$G(BIKEY) S BIERR=635 Q
  1.  ;
  1.  N BIKEYNM
  1.  D
  1.  .I BIKEY=1 S BIKEYNM="BIZMENU" Q
  1.  .I BIKEY=2 S BIKEYNM="BIZ EDIT PATIENTS" Q
  1.  .I BIKEY=3 S BIKEYNM="BIZ MANAGER" Q
  1.  .I BIKEY=4 S BIKEYNM="BIZ LOT ONLY"
  1.  I $G(BIKEYNM)="" S BIERR=635 Q
  1.  ;
  1.  ;---> Set BIKIEN=Key IEN.
  1.  N BIKIEN S BIKIEN=$O(^DIC(19.1,"B",BIKEYNM,0))
  1.  ;---> Quit if Key does not exist.
  1.  I 'BIKIEN S BIERR=632 Q
  1.  ;---> Quit if there are duplicate keys.
  1.  I $O(^DIC(19.1,"B",BIKEY,BIKIEN)) S BIERR=633 Q
  1.  ;
  1.  ;---> Quit if BIALL not specified.
  1.  I ($G(BIALL)'=0)&($G(BIALL)'=1) S BIERR=634 Q
  1.  ;
  1.  ;---> Deallocate, quit.
  1.  I BIALL=0 D  Q
  1.  .N DIK,DA S DIK="^VA(200,"_BIDUZ_",51,",DA(1)=BIDUZ,DA=BIKIEN
  1.  .D ^DIK
  1.  ;
  1.  ;---> Allocate.
  1.  Q:$D(^XUSEC(BIKEYNM,BIDUZ))  ;already has new key
  1.  N DIC,DD,DO  K DO
  1.  S DIC(0)="NMQ",DIC("P")="200.051PA"
  1.  S DIC="^VA(200,"_BIDUZ_",51,",DA(1)=BIDUZ,X=BIKIEN,DINUM=X
  1.  D FILE^DICN
  1.  I Y<0 S BIERR=636
  1.  K DIC,DINUM,DA
  1.  Q
  1.  ;
  1.  ;
  1.  ;----------
  1. TITLE ;EP
  1.  ;---> Clear screen and write title.
  1.  D TITLE^BIUTL5("ALLOCATE/DEALLOCATE IMM KEYS")
  1.  Q
  1.  ;
  1.  ;
  1.  ;----------
  1. NOCHANGE ;EP
  1.  W !!?5,"NO changes made." D DIRZ^BIUTL3()
  1.  Q
  1.  ;
  1.  ;
  1.  ;----------
  1. PRINTX(BILINL,BITAB) ;EP
  1.  Q:$G(BILINL)=""
  1.  N I,T,X S T="" S:'$D(BITAB) BITAB=5 F I=1:1:BITAB S T=T_" "
  1.  F I=1:1 S X=$T(@BILINL+I) Q:X'[";;"  W !,T,$P(X,";;",2)
  1.  Q