VENPCCQZ ; IHS/OIT/GIS - POST INSTALL & APPLICATION CONFIG OPTION ; [ 03/31/09 5:36 PM ]
;;2.6;PCC+;**1,3**;MAR 23, 2011
;
;
;
VPTED ; EP - UPDATE V PATIENT ED FILE
N X,Y,Z
I $L($T(^VENLINIT)) D
. W !,"It looks like you need to update the V PATIENT ED file..."
. W !,"When asked if you want to overwrite security codes, answer 'YES'"
. W !,"When asked if everything is OK, answer 'YES'",!!
. D ^VENLINIT
. W !
. Q
Q
;
VWC ; EP - UPDATE V WELL CHILD FILE"
N X,Y,Z
I $L($T(^VENLINIT)) D
. W !,"It looks like you need to install the V WELL CHILD file..."
. W !,"When asked if you want to overwrite security codes, answer 'YES'"
. W !,"When asked if everything is OK, answer 'YES'"
. D ^VENMINIT
. W !
. Q
Q
;
MP ; EP - SET MEASUREMENT PANELS CORRECTLY
N TIEN,X,Y,Z,%,DA,DIC,DIE,DIK,MP,PS,PSM,ASQ,PIEN
S TIEN=$O(^APCHSCTL("B","WELL CHILD EXAM",0)) I 'TIEN Q
S PS=$O(^APCHSMPN("B","PEDIATRIC STD",0))
S PSM=$O(^APCHSMPN("B","PEDIATRIC STD METRIC",0))
S ASQ=$O(^APCHSMPN("B","ASQ DEVELOPMENT SCORES",0))
S PIEN=0,Z=""
F S PIEN=$O(^APCHSCTL(TIEN,3,PIEN)) Q:'PIEN D
. S X=$G(^APCHSCTL(TIEN,3,PIEN,0)) I '$L(X) Q
. S Y=$P(X,U,2)
. I Y=PS S Z=Z_"PS^" Q
. I Y=PSM S Z=Z_"PSM^" Q
. I Y=ASQ S Z=Z_"ASQ" Q
. ; KILL OF BAD PANEL
. S DA(1)=TIEN,DIK="^APCHSCTL("_DA(1)_",3,",DA=PIEN
. D ^DIK
. Q
S DA(1)=TIEN,DIC="^APCHSCTL("_DA(1)_",3,"
S DIC(0)="L",DIC("P")=$P(^DD(9001015,4,0),U,2),DLAYGO=9001015.02
I Z'["PS" D
. S X=$O(^APCHSCTL(TIEN,3,9999),-1)+1
. D ^DIC I Y=-1 Q
. S $P(^APCHSCTL(TIEN,3,+Y,0),U,2)=PS
. Q
I Z'["ASQ" D
. S X=$O(^APCHSCTL(TIEN,3,9999),-1)+1
. D ^DIC I Y=-1 Q
. S $P(^APCHSCTL(TIEN,3,+Y,0),U,2)=ASQ
. Q
W !?5,"The correct measurement panels have been assigned to this component"
D ^XBFMK
Q
;
CMP(Z) ; EP - CHECK COMPONENTS OF WELL CHILD EXAM HEALTH SUMMARY
N WIEN,MIEN,DIEN,TIEN,CIEN,X,Y,%
S Z=0
S TIEN=$O(^APCHSCTL("B","WELL CHILD EXAM",0)) I 'TIEN Q
S WIEN=$O(^APCHSCMP("B","WELL CHILD EXAM",0))
S MIEN=$O(^APCHSCMP("B","MEASUREMENT PANELS",0))
S DIEN=$O(^APCHSCMP("B","DEMOGRAPHIC DATA",0))
S %=$NA(^APCHSCTL(TIEN,1)),Z=$P($G(@%@(30,0)),U,2) I Z,Z'=WIEN,'$D(@%@("B",31)) D
. K @%@(30,0) S @%@(31,0)=31_U_WIEN
. K @%@("B",30) S @%@("B",31,31)=""
. K @%@("C",Z) S @%@("C",WIEN,31)=""
. Q
S Y="",CIEN=0,Z=0
F S CIEN=$O(^APCHSCTL(TIEN,1,CIEN)) Q:'CIEN D
. S %=+$P($G(^APCHSCTL(TIEN,1,CIEN,0)),U,2)
. I %=WIEN S Y=Y_"WCE^" Q
. I %=MIEN S Y=Y_"MP^" Q
. I %=DIEN S Y=Y_"DP^"
. Q
I Y'["WCE" W !?5,"The WELL CHILD EXAM component is missing" S Z=1 Q
I Y'["MP" W !?5,"The MEASUREMENT PANEL component is missing" S Z=1 Q
I Y'["DP" W !?5,"The DEMOGRAPHIC component is missing" S Z=1 Q
W !?5,"All required components are present"
Q
;
N %,%Y,DIC,DIE,DA,DR,X,Y,Z,DFN,BIEN,VIEN
S VIEN=$O(^DIC(19,"B","VEN RPC",0)) I 'VIEN Q
S BIEN=$O(^DIC(19,"B","BMXRPC",0)) I 'BIEN Q
W !!,"Broker options can also be assigned to specific users who do not use"
W !,"any of the primary menus listed above."
W !,"Want to allow these special users to access WCM desktop components"
S %=2 D YN^DICN I %'=1 Q
S DIC("A")="Enter the name of a user that needs access privileges: "
SMORE S DIC=200,DIC(0)="AEQM"
D ^DIC I Y=-1 D ^XBFMK Q
S DFN=+Y
I $D(^VA(200,DFN,203,"B",VIEN)),$D(^VA(200,DFN,203,"B",BIEN)) W !,"This user already has access" G SMORE
W !,"Are you sure you want to allow access for this user"
S %=1 D YN^DICN I %'=1 G SMLOOP
S DA(1)=DFN,DIC="^VA(200,"_DA(1)_",203,",(DLAYGO,DIC("P"))=200.03,DIC(0)="L"
F X=("`"_VIEN),("`"_BIEN) D ^DIC
K DIC
I Y=-1 W "Unable to assign access privileges to this user!!!"
E W !,"OK, secondary menu options have been assigned to provide access for this user.",!
S DIC("A")="Enter another user that needs access privileges: "
SMLOOP G SMORE
;
HOLD(KEY) ; EP - SECURITY KEY HOLDERS
N DFN,NAME,%,Y,PRIV,KIEN,Z
S PRIV=0,KIEN=$O(^DIC(19.1,"B",KEY,0)) I 'KIEN Q
I DUZ(0)="@"!$D(^VA(200,DUZ,52,KIEN,0))!$D(^XUSEC("XUMGR",DUZ)) S PRIV=1 ; USER HAS KEY ALLOCATION PRIVELEGES
I $O(^XUSEC(KEY,0)) D G:PRIV HOLD1 Q
. S DFN=0 W !?15,"Holders:"
. F S DFN=$O(^XUSEC(KEY,DFN)) Q:'DFN S NAME=$P($G(^VA(200,DFN,0)),U) I $L(NAME) W !?20,NAME
. Q
W !?15,"Currently no users hold this key!"
I 'PRIV Q
W !?15,"Want to assign it to yourself"
S %=1 D YN^DICN
I %=1 S Y=$$ADDKEY(DUZ,KIEN,1)
HOLD1 W !!?2,"Want to assign ",KEY," to any other IT personnel or supervisors"
S %=2 D YN^DICN
I %'=1 Q
S Y=$$ADDKEY(DUZ,KIEN) I Y=-1 Q
G HOLD1 ; GET ANOTHER KEYHOLDER
;
ADDKEY(USER,KIEN,SELF) ; EP - ALLOCATE A KEY TO A USER
N DIC,X,Y,%,DA,DR,DIE,TODAY,SCIEN
I $G(SELF) S Y=DUZ G AK1
S DIC=200,DIC(0)="AEQM",DIC("A")="Allocate this key to: "
D ^DIC I Y=-1 Q Y
S SCIEN=$O(^VA(200,+Y,51,"B",KIEN,0)) I SCIEN D Q 1 ; THIS USER ALREADY HAS THE KEY
. W !,"This user already holds this key!",!,"Want to de-allocate the key"
. S %=2 D YN^DICN I %'=1 D ^XBFMK Q
. S DA(1)=+Y,DA=SCIEN,DIK="^VA(200,"_DA(1)_",51,"
. D ^DIK,^XBFMK W " (Key de-allocated)"
. Q
AK1 S DA(1)=+Y,DIC="^VA(200,"_DA(1)_",51,",DIC("P")="200.051PA",DIC(0)="L",DLAYGO=200.051
S X="`"_KIEN
D ^DIC I Y=-1 Q Y
S DIE=DIC,DR=".02////^S X=USER;.03////^S X=TODAY"
L +^VA(200,DA(1)):1 I D ^DIE L -^VA(200,DA(1))
W " <- Allocated"
D ^XBFMK
Q 1
;
N BIEN,Y,TOT,Z,MIEN,X,%,DIC,DIE,DA,DR,%Y,XIEN
W !!,"CHECKING BROKER OPTION LINKS"
W !,"In order to access the WCM desktop components, certain broker options must"
W !,"be linked to the PRIMARY MENU of clinic nurses and doctors who use the WCM."
W !,"(One moment please...) "
S BIEN=$O(^DIC(19,"B","VEN RPC",0)) I 'BIEN Q
S XIEN=$O(^DIC(19,"B","BMXRPC",0)) I 'XIEN Q
S Y=0 K TOT S TOT=0
F S Y=$O(^DIC(19,Y)) Q:'Y I $D(^DIC(19,Y,10,"B",BIEN)) S TOT=TOT+1,TOT(TOT)=Y
I '$D(TOT) W !,"The broker option 'VEN RPC' has not been linked to any user menu!" G MENU1
W !!,"The broker option 'VEN RPC' is assigned to the following menu(s):"
S TOT=0 F S TOT=$O(TOT(TOT)) Q:'TOT S Y=$G(TOT(TOT)) I Y D
. S Z=$P($G(^DIC(19,Y,0)),U) I '$L(Z) Q
. W !?5,TOT,". ",Z
. Q
I '$D(TOT(1)) W " NONE!",!,"Want to assign VEN RPC to a menu"
E W !,"Want to make any changes to the 'VEN RPC' assignments"
S %=2 D YN^DICN I %'=1 Q
S DIC("A")="Enter the name of a host menu: "
W !! D ^DIC I Y=-1 Q
S MIEN=+Y
I $P($G(^DIC(19,MIEN,0)),U,4)'="M" D G MENU1 ; OPTION TYPE MUST BE 'MENU'
. W !,"VEN RPC must be associated with a menu option"
. W !,$P(Y,U,2)," is not a menu option. Try again"
. Q
I $D(^DIC(19,MIEN,10,"B",BIEN)) D G MENU1 ; VEN RPC IS ALREADY ASSOCIATED WITH THIS MENU
. W !,"VEN RPC is already associated with this option."
. W !,"Want to remove VEN RPC from this menu"
. S %=2 D YN^DICN I %'=1 Q
. S (D0,DA(1))=MIEN,DIK="^DIC(19,"_DA(1)_",10,",DA=$O(^DIC(19,MIEN,10,"B",BIEN,0))
. I DA D ^DIK W !,"VEN RPC has been removed from this menu"
. Q
S X=$O(^DIC(19,MIEN,10,0))+1,Y=$G(^DIC(19,MIEN,10,0)),Z=$NA(^DIC(19,MIEN,10))
I '$L(Y) S @Z@(0)="^19.01PI^1^1"
E S %=$P(@Z@(0),U,3)+1,@Z@(0)="^19.01^"_%_U_%
S @Z@(X,0)=BIEN_"^RPC",@Z@("B",BIEN,X)=""
W !,"VEN RPC is now associated with this option"
I $D(@Z@("B",XIEN)) G MENU1
S %=$P(@Z@(0),U,3)+1,@Z@(0)="^19.01^"_%_U_%
S X=$O(^DIC(19,MIEN,10,0))+1
S @Z@(X,0)=XIEN_"^RPC",@Z@("B",XIEN,X)="" ; ALSO ADD BMXRPC
G MENU1
;
DINFO ; EP - CHECK/FIX KB DOMAIN POINTERS
N MNIEN,DIEN,STG,X,Y,%,TYPE,NAME,GBL,TXT
S MNIEN=$O(^APCDTKW("B","OCM",0)) I 'MNIEN Q
S GBL=$NA(^VEN(7.13)),(NAME,TXT)="OB NATL"
F S NAME=$O(@GBL@("B",NAME)) Q:NAME'[TXT D
. S DIEN=$O(@GBL@("B",NAME,0))
. I '$D(@GBL@(DIEN,0)) Q
. S $P(@GBL@(DIEN,0),U,3)=MNIEN
. S $P(@GBL@(DIEN,0),U,4)=$S(NAME[" PP AG ":"OBAG",NAME[" PP EXAM ":"OBEX",NAME[" NATL EXAM ":"OBEX",NAME[" NATL AG ":"OBAG",1:"")
. Q
W !?10,"Knowledgebase domain definitions have been verified"
Q
;
ACT ; EP - MANAGE WCM DOMIANS: MAKE THEM ACTIVE OR INCATIVE
N %,%Y,DIR,DIC,DIE,DA,DR,X,Y,Z,%,DIEN,TOT
W !!,"Checking Knowledgebase domains... ",!
K TOT D ACTL
S %=2 W !!,"Want to change the status of any of these elements"
D YN^DICN I %'=1 Q
S DIR("A")="Which element"
ACT1 S DIR(0)="NO^1:"_TOT_":0"
D ^DIR I 'Y Q
S DA=$G(TOT(Y)) I 'DA Q
S DIE="^VEN(7.13,",DR=".07Is this domain active?"
L +^VEN(7.13,DA):1 I D ^DIE L -^VEN(7.13,DA)
D ACTL
S DIR("A")="Another element" W !! G ACT1
;
ACTL ; EP - SHOW IF DOMAIN IS ACTIVE
S DIEN=0,TOT=0
F S DIEN=$O(^VEN(7.13,DIEN)) Q:'DIEN D
. S X=$G(^VEN(7.13,DIEN,0))
. S Y=$P(X,U) I Y'["WELL CHILD" Q
. S Z=$P(X,U,7),TOT=TOT+1,TOT(TOT)=DIEN
. W !?5,TOT,". ",Y," <-",$S(Z'=1:"IN",1:""),"ACTIVE"
. Q
Q
;
XRT ; EP - MAKE SURE EXTERNAL ROUTINES ARE PRESENT
Q
W !!,"CHECKING REQUIRED ROUTINES OUTSIDE OF THE WCM PACKAGE..."
I '$L($T(WCE^APCHS6B)) W !?5,"The routine APCHS6B is missing!"
E W !?5,"^APCHS6B",?15,"<- OK"
I '$L($T(DATA^VENPCCQB)) W !?5,"The routine VENPCCQB is missing!"
E W !?5,"^VENPCCQB",?15,"<- OK"
I '$L($T(VWC^VENPCCQC)) W !?5,"The routine VENPCCQB is missing!"
E W !?5,"^VENPCCQB",?15,"<- OK"
I '$L($T(EXAM^VENPCCQD)) W !?5,"The routine VENPCCQD is missing!"
E W !?5,"^VENPCCQD",?15,"<- OK"
I '$L($T(SS^BMXADO)) W !?5,"The Broker routines (BMX*) are missing!"
E W !?5,"The Broker routines (BMX*) are loaded"
Q
;
VENPCCQZ ; IHS/OIT/GIS - POST INSTALL & APPLICATION CONFIG OPTION ; [ 03/31/09 5:36 PM ]
+1 ;;2.6;PCC+;**1,3**;MAR 23, 2011
+2 ;
+3 ;
+4 ;
VPTED ; EP - UPDATE V PATIENT ED FILE
+1 NEW X,Y,Z
+2 IF $LENGTH($TEXT(^VENLINIT))
Begin DoDot:1
+3 WRITE !,"It looks like you need to update the V PATIENT ED file..."
+4 WRITE !,"When asked if you want to overwrite security codes, answer 'YES'"
+5 WRITE !,"When asked if everything is OK, answer 'YES'",!!
+6 DO ^VENLINIT
+7 WRITE !
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
VWC ; EP - UPDATE V WELL CHILD FILE"
+1 NEW X,Y,Z
+2 IF $LENGTH($TEXT(^VENLINIT))
Begin DoDot:1
+3 WRITE !,"It looks like you need to install the V WELL CHILD file..."
+4 WRITE !,"When asked if you want to overwrite security codes, answer 'YES'"
+5 WRITE !,"When asked if everything is OK, answer 'YES'"
+6 DO ^VENMINIT
+7 WRITE !
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
MP ; EP - SET MEASUREMENT PANELS CORRECTLY
+1 NEW TIEN,X,Y,Z,%,DA,DIC,DIE,DIK,MP,PS,PSM,ASQ,PIEN
+2 SET TIEN=$ORDER(^APCHSCTL("B","WELL CHILD EXAM",0))
IF 'TIEN
QUIT
+3 SET PS=$ORDER(^APCHSMPN("B","PEDIATRIC STD",0))
+4 SET PSM=$ORDER(^APCHSMPN("B","PEDIATRIC STD METRIC",0))
+5 SET ASQ=$ORDER(^APCHSMPN("B","ASQ DEVELOPMENT SCORES",0))
+6 SET PIEN=0
SET Z=""
+7 FOR
SET PIEN=$ORDER(^APCHSCTL(TIEN,3,PIEN))
IF 'PIEN
QUIT
Begin DoDot:1
+8 SET X=$GET(^APCHSCTL(TIEN,3,PIEN,0))
IF '$LENGTH(X)
QUIT
+9 SET Y=$PIECE(X,U,2)
+10 IF Y=PS
SET Z=Z_"PS^"
QUIT
+11 IF Y=PSM
SET Z=Z_"PSM^"
QUIT
+12 IF Y=ASQ
SET Z=Z_"ASQ"
QUIT
+13 ; KILL OF BAD PANEL
+14 SET DA(1)=TIEN
SET DIK="^APCHSCTL("_DA(1)_",3,"
SET DA=PIEN
+15 DO ^DIK
+16 QUIT
End DoDot:1
+17 SET DA(1)=TIEN
SET DIC="^APCHSCTL("_DA(1)_",3,"
+18 SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(9001015,4,0),U,2)
SET DLAYGO=9001015.02
+19 IF Z'["PS"
Begin DoDot:1
+20 SET X=$ORDER(^APCHSCTL(TIEN,3,9999),-1)+1
+21 DO ^DIC
IF Y=-1
QUIT
+22 SET $PIECE(^APCHSCTL(TIEN,3,+Y,0),U,2)=PS
+23 QUIT
End DoDot:1
+24 IF Z'["ASQ"
Begin DoDot:1
+25 SET X=$ORDER(^APCHSCTL(TIEN,3,9999),-1)+1
+26 DO ^DIC
IF Y=-1
QUIT
+27 SET $PIECE(^APCHSCTL(TIEN,3,+Y,0),U,2)=ASQ
+28 QUIT
End DoDot:1
+29 WRITE !?5,"The correct measurement panels have been assigned to this component"
+30 DO ^XBFMK
+31 QUIT
+32 ;
CMP(Z) ; EP - CHECK COMPONENTS OF WELL CHILD EXAM HEALTH SUMMARY
+1 NEW WIEN,MIEN,DIEN,TIEN,CIEN,X,Y,%
+2 SET Z=0
+3 SET TIEN=$ORDER(^APCHSCTL("B","WELL CHILD EXAM",0))
IF 'TIEN
QUIT
+4 SET WIEN=$ORDER(^APCHSCMP("B","WELL CHILD EXAM",0))
+5 SET MIEN=$ORDER(^APCHSCMP("B","MEASUREMENT PANELS",0))
+6 SET DIEN=$ORDER(^APCHSCMP("B","DEMOGRAPHIC DATA",0))
+7 SET %=$NAME(^APCHSCTL(TIEN,1))
SET Z=$PIECE($GET(@%@(30,0)),U,2)
IF Z
IF Z'=WIEN
IF '$DATA(@%@("B",31))
Begin DoDot:1
+8 KILL @%@(30,0)
SET @%@(31,0)=31_U_WIEN
+9 KILL @%@("B",30)
SET @%@("B",31,31)=""
+10 KILL @%@("C",Z)
SET @%@("C",WIEN,31)=""
+11 QUIT
End DoDot:1
+12 SET Y=""
SET CIEN=0
SET Z=0
+13 FOR
SET CIEN=$ORDER(^APCHSCTL(TIEN,1,CIEN))
IF 'CIEN
QUIT
Begin DoDot:1
+14 SET %=+$PIECE($GET(^APCHSCTL(TIEN,1,CIEN,0)),U,2)
+15 IF %=WIEN
SET Y=Y_"WCE^"
QUIT
+16 IF %=MIEN
SET Y=Y_"MP^"
QUIT
+17 IF %=DIEN
SET Y=Y_"DP^"
+18 QUIT
End DoDot:1
+19 IF Y'["WCE"
WRITE !?5,"The WELL CHILD EXAM component is missing"
SET Z=1
QUIT
+20 IF Y'["MP"
WRITE !?5,"The MEASUREMENT PANEL component is missing"
SET Z=1
QUIT
+21 IF Y'["DP"
WRITE !?5,"The DEMOGRAPHIC component is missing"
SET Z=1
QUIT
+22 WRITE !?5,"All required components are present"
+23 QUIT
+24 ;
+1 NEW %,%Y,DIC,DIE,DA,DR,X,Y,Z,DFN,BIEN,VIEN
+2 SET VIEN=$ORDER(^DIC(19,"B","VEN RPC",0))
IF 'VIEN
QUIT
+3 SET BIEN=$ORDER(^DIC(19,"B","BMXRPC",0))
IF 'BIEN
QUIT
+4 WRITE !!,"Broker options can also be assigned to specific users who do not use"
+5 WRITE !,"any of the primary menus listed above."
+6 WRITE !,"Want to allow these special users to access WCM desktop components"
+7 SET %=2
DO YN^DICN
IF %'=1
QUIT
+8 SET DIC("A")="Enter the name of a user that needs access privileges: "
SMORE SET DIC=200
SET DIC(0)="AEQM"
+1 DO ^DIC
IF Y=-1
DO ^XBFMK
QUIT
+2 SET DFN=+Y
+3 IF $DATA(^VA(200,DFN,203,"B",VIEN))
IF $DATA(^VA(200,DFN,203,"B",BIEN))
WRITE !,"This user already has access"
GOTO SMORE
+4 WRITE !,"Are you sure you want to allow access for this user"
+5 SET %=1
DO YN^DICN
IF %'=1
GOTO SMLOOP
+6 SET DA(1)=DFN
SET DIC="^VA(200,"_DA(1)_",203,"
SET (DLAYGO,DIC("P"))=200.03
SET DIC(0)="L"
+7 FOR X=("`"_VIEN),("`"_BIEN)
DO ^DIC
+8 KILL DIC
+9 IF Y=-1
WRITE "Unable to assign access privileges to this user!!!"
+10 IF '$TEST
WRITE !,"OK, secondary menu options have been assigned to provide access for this user.",!
+11 SET DIC("A")="Enter another user that needs access privileges: "
SMLOOP GOTO SMORE
+1 ;
HOLD(KEY) ; EP - SECURITY KEY HOLDERS
+1 NEW DFN,NAME,%,Y,PRIV,KIEN,Z
+2 SET PRIV=0
SET KIEN=$ORDER(^DIC(19.1,"B",KEY,0))
IF 'KIEN
QUIT
+3 ; USER HAS KEY ALLOCATION PRIVELEGES
IF DUZ(0)="@"!$DATA(^VA(200,DUZ,52,KIEN,0))!$DATA(^XUSEC("XUMGR",DUZ))
SET PRIV=1
+4 IF $ORDER(^XUSEC(KEY,0))
Begin DoDot:1
+5 SET DFN=0
WRITE !?15,"Holders:"
+6 FOR
SET DFN=$ORDER(^XUSEC(KEY,DFN))
IF 'DFN
QUIT
SET NAME=$PIECE($GET(^VA(200,DFN,0)),U)
IF $LENGTH(NAME)
WRITE !?20,NAME
+7 QUIT
End DoDot:1
IF PRIV
GOTO HOLD1
QUIT
+8 WRITE !?15,"Currently no users hold this key!"
+9 IF 'PRIV
QUIT
+10 WRITE !?15,"Want to assign it to yourself"
+11 SET %=1
DO YN^DICN
+12 IF %=1
SET Y=$$ADDKEY(DUZ,KIEN,1)
HOLD1 WRITE !!?2,"Want to assign ",KEY," to any other IT personnel or supervisors"
+1 SET %=2
DO YN^DICN
+2 IF %'=1
QUIT
+3 SET Y=$$ADDKEY(DUZ,KIEN)
IF Y=-1
QUIT
+4 ; GET ANOTHER KEYHOLDER
GOTO HOLD1
+5 ;
ADDKEY(USER,KIEN,SELF) ; EP - ALLOCATE A KEY TO A USER
+1 NEW DIC,X,Y,%,DA,DR,DIE,TODAY,SCIEN
+2 IF $GET(SELF)
SET Y=DUZ
GOTO AK1
+3 SET DIC=200
SET DIC(0)="AEQM"
SET DIC("A")="Allocate this key to: "
+4 DO ^DIC
IF Y=-1
QUIT Y
+5 ; THIS USER ALREADY HAS THE KEY
SET SCIEN=$ORDER(^VA(200,+Y,51,"B",KIEN,0))
IF SCIEN
Begin DoDot:1
+6 WRITE !,"This user already holds this key!",!,"Want to de-allocate the key"
+7 SET %=2
DO YN^DICN
IF %'=1
DO ^XBFMK
QUIT
+8 SET DA(1)=+Y
SET DA=SCIEN
SET DIK="^VA(200,"_DA(1)_",51,"
+9 DO ^DIK
DO ^XBFMK
WRITE " (Key de-allocated)"
+10 QUIT
End DoDot:1
QUIT 1
AK1 SET DA(1)=+Y
SET DIC="^VA(200,"_DA(1)_",51,"
SET DIC("P")="200.051PA"
SET DIC(0)="L"
SET DLAYGO=200.051
+1 SET X="`"_KIEN
+2 DO ^DIC
IF Y=-1
QUIT Y
+3 SET DIE=DIC
SET DR=".02////^S X=USER;.03////^S X=TODAY"
+4 LOCK +^VA(200,DA(1)):1
IF $TEST
DO ^DIE
LOCK -^VA(200,DA(1))
+5 WRITE " <- Allocated"
+6 DO ^XBFMK
+7 QUIT 1
+8 ;
+1 NEW BIEN,Y,TOT,Z,MIEN,X,%,DIC,DIE,DA,DR,%Y,XIEN
+2 WRITE !!,"CHECKING BROKER OPTION LINKS"
+3 WRITE !,"In order to access the WCM desktop components, certain broker options must"
+4 WRITE !,"be linked to the PRIMARY MENU of clinic nurses and doctors who use the WCM."
+5 WRITE !,"(One moment please...) "
+6 SET BIEN=$ORDER(^DIC(19,"B","VEN RPC",0))
IF 'BIEN
QUIT
+7 SET XIEN=$ORDER(^DIC(19,"B","BMXRPC",0))
IF 'XIEN
QUIT
+8 SET Y=0
KILL TOT
SET TOT=0
+9 FOR
SET Y=$ORDER(^DIC(19,Y))
IF 'Y
QUIT
IF $DATA(^DIC(19,Y,10,"B",BIEN))
SET TOT=TOT+1
SET TOT(TOT)=Y
+10 IF '$DATA(TOT)
WRITE !,"The broker option 'VEN RPC' has not been linked to any user menu!"
GOTO MENU1
+11 WRITE !!,"The broker option 'VEN RPC' is assigned to the following menu(s):"
+12 SET TOT=0
FOR
SET TOT=$ORDER(TOT(TOT))
IF 'TOT
QUIT
SET Y=$GET(TOT(TOT))
IF Y
Begin DoDot:1
+13 SET Z=$PIECE($GET(^DIC(19,Y,0)),U)
IF '$LENGTH(Z)
QUIT
+14 WRITE !?5,TOT,". ",Z
+15 QUIT
End DoDot:1
+16 IF '$DATA(TOT(1))
WRITE " NONE!",!,"Want to assign VEN RPC to a menu"
+17 IF '$TEST
WRITE !,"Want to make any changes to the 'VEN RPC' assignments"
+18 SET %=2
DO YN^DICN
IF %'=1
QUIT
+19 SET DIC("A")="Enter the name of a host menu: "
SET DIC(0)="AEQM"
+1 WRITE !!
DO ^DIC
IF Y=-1
QUIT
+2 SET MIEN=+Y
+3 ; OPTION TYPE MUST BE 'MENU'
IF $PIECE($GET(^DIC(19,MIEN,0)),U,4)'="M"
Begin DoDot:1
+4 WRITE !,"VEN RPC must be associated with a menu option"
+5 WRITE !,$PIECE(Y,U,2)," is not a menu option. Try again"
+6 QUIT
End DoDot:1
GOTO MENU1
+7 ; VEN RPC IS ALREADY ASSOCIATED WITH THIS MENU
IF $DATA(^DIC(19,MIEN,10,"B",BIEN))
Begin DoDot:1
+8 WRITE !,"VEN RPC is already associated with this option."
+9 WRITE !,"Want to remove VEN RPC from this menu"
+10 SET %=2
DO YN^DICN
IF %'=1
QUIT
+11 SET (D0,DA(1))=MIEN
SET DIK="^DIC(19,"_DA(1)_",10,"
SET DA=$ORDER(^DIC(19,MIEN,10,"B",BIEN,0))
+12 IF DA
DO ^DIK
WRITE !,"VEN RPC has been removed from this menu"
+13 QUIT
End DoDot:1
GOTO MENU1
+14 SET X=$ORDER(^DIC(19,MIEN,10,0))+1
SET Y=$GET(^DIC(19,MIEN,10,0))
SET Z=$NAME(^DIC(19,MIEN,10))
+15 IF '$LENGTH(Y)
SET @Z@(0)="^19.01PI^1^1"
+16 IF '$TEST
SET %=$PIECE(@Z@(0),U,3)+1
SET @Z@(0)="^19.01^"_%_U_%
+17 SET @Z@(X,0)=BIEN_"^RPC"
SET @Z@("B",BIEN,X)=""
+18 WRITE !,"VEN RPC is now associated with this option"
+19 IF $DATA(@Z@("B",XIEN))
GOTO MENU1
+20 SET %=$PIECE(@Z@(0),U,3)+1
SET @Z@(0)="^19.01^"_%_U_%
+21 SET X=$ORDER(^DIC(19,MIEN,10,0))+1
+22 ; ALSO ADD BMXRPC
SET @Z@(X,0)=XIEN_"^RPC"
SET @Z@("B",XIEN,X)=""
+23 GOTO MENU1
+24 ;
DINFO ; EP - CHECK/FIX KB DOMAIN POINTERS
+1 NEW MNIEN,DIEN,STG,X,Y,%,TYPE,NAME,GBL,TXT
+2 SET MNIEN=$ORDER(^APCDTKW("B","OCM",0))
IF 'MNIEN
QUIT
+3 SET GBL=$NAME(^VEN(7.13))
SET (NAME,TXT)="OB NATL"
+4 FOR
SET NAME=$ORDER(@GBL@("B",NAME))
IF NAME'[TXT
QUIT
Begin DoDot:1
+5 SET DIEN=$ORDER(@GBL@("B",NAME,0))
+6 IF '$DATA(@GBL@(DIEN,0))
QUIT
+7 SET $PIECE(@GBL@(DIEN,0),U,3)=MNIEN
+8 SET $PIECE(@GBL@(DIEN,0),U,4)=$SELECT(NAME[" PP AG ":"OBAG",NAME[" PP EXAM ":"OBEX",NAME[" NATL EXAM ":"OBEX",NAME[" NATL AG ":"OBAG",1:"")
+9 QUIT
End DoDot:1
+10 WRITE !?10,"Knowledgebase domain definitions have been verified"
+11 QUIT
+12 ;
ACT ; EP - MANAGE WCM DOMIANS: MAKE THEM ACTIVE OR INCATIVE
+1 NEW %,%Y,DIR,DIC,DIE,DA,DR,X,Y,Z,%,DIEN,TOT
+2 WRITE !!,"Checking Knowledgebase domains... ",!
+3 KILL TOT
DO ACTL
+4 SET %=2
WRITE !!,"Want to change the status of any of these elements"
+5 DO YN^DICN
IF %'=1
QUIT
+6 SET DIR("A")="Which element"
ACT1 SET DIR(0)="NO^1:"_TOT_":0"
+1 DO ^DIR
IF 'Y
QUIT
+2 SET DA=$GET(TOT(Y))
IF 'DA
QUIT
+3 SET DIE="^VEN(7.13,"
SET DR=".07Is this domain active?"
+4 LOCK +^VEN(7.13,DA):1
IF $TEST
DO ^DIE
LOCK -^VEN(7.13,DA)
+5 DO ACTL
+6 SET DIR("A")="Another element"
WRITE !!
GOTO ACT1
+7 ;
ACTL ; EP - SHOW IF DOMAIN IS ACTIVE
+1 SET DIEN=0
SET TOT=0
+2 FOR
SET DIEN=$ORDER(^VEN(7.13,DIEN))
IF 'DIEN
QUIT
Begin DoDot:1
+3 SET X=$GET(^VEN(7.13,DIEN,0))
+4 SET Y=$PIECE(X,U)
IF Y'["WELL CHILD"
QUIT
+5 SET Z=$PIECE(X,U,7)
SET TOT=TOT+1
SET TOT(TOT)=DIEN
+6 WRITE !?5,TOT,". ",Y," <-",$SELECT(Z'=1:"IN",1:""),"ACTIVE"
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
XRT ; EP - MAKE SURE EXTERNAL ROUTINES ARE PRESENT
+1 QUIT
+2 WRITE !!,"CHECKING REQUIRED ROUTINES OUTSIDE OF THE WCM PACKAGE..."
+3 IF '$LENGTH($TEXT(WCE^APCHS6B))
WRITE !?5,"The routine APCHS6B is missing!"
+4 IF '$TEST
WRITE !?5,"^APCHS6B",?15,"<- OK"
+5 IF '$LENGTH($TEXT(DATA^VENPCCQB))
WRITE !?5,"The routine VENPCCQB is missing!"
+6 IF '$TEST
WRITE !?5,"^VENPCCQB",?15,"<- OK"
+7 IF '$LENGTH($TEXT(VWC^VENPCCQC))
WRITE !?5,"The routine VENPCCQB is missing!"
+8 IF '$TEST
WRITE !?5,"^VENPCCQB",?15,"<- OK"
+9 IF '$LENGTH($TEXT(EXAM^VENPCCQD))
WRITE !?5,"The routine VENPCCQD is missing!"
+10 IF '$TEST
WRITE !?5,"^VENPCCQD",?15,"<- OK"
+11 IF '$LENGTH($TEXT(SS^BMXADO))
WRITE !?5,"The Broker routines (BMX*) are missing!"
+12 IF '$TEST
WRITE !?5,"The Broker routines (BMX*) are loaded"
+13 QUIT
+14 ;
