VENPCCK1 ; IHS/OIT/GIS - KNOWLEDGE BASE ;
;;2.6;PCC+;;NOV 12, 2007
; RPMS DIALOGUE
;
;
AGE ; EP - DIALOGUE FOR AGE-SEX SPECIFIC ITEMS
N AGE
S AGE=1
D CAT
Q
;
CAT ; EP - GET THE KB CATEGORY
N DIC,X,Y,Z,%,CIEN,IIEN,DIR,DA,DIK,%Y
S DIC("A")="Enter the name of the knowledgebase category: "
S DIC="^VEN(7.11,",DIC(0)="AEQML",DLAYGO=19707.11
D ^DIC I Y=-1 D ^XBFMK Q
S CIEN=+Y
I $P(Y,U,3) D ITEM(CIEN) Q
M1 W !!,"What do you want to do next ->"
W !,?3,"1. Add or edit items in this category."
W !,?3,"2. Delete this KB category."
W !,?3,"3. Quit."
S DIR(0)="N^1:3:0",DIR("A")="Your choice",DIR("B")="1" D ^DIR
I Y=1 D ITEM(CIEN) Q
I Y=3!('Y) D ^XBFMK Q
I Y=2 W !!,"This will DELETE the category and all items associated with it!!!"
W !,"Are you sure you want to do this"
S %=2 D YN^DICN
I %'=1 W ! G M1
S DIK="^VEN(7.11,",DA=CIEN D ^DIK
S DA=0,DIK="^VEN(7.12,"
F S DA=$O(^VEN(7.12,"B",CIEN,DA)) Q:'DA D ^DIK ; CLEAN OUT THE ASSOCIATED ITEMS
W !," *** CATEGORY DELETED ***"
D ^XBFMK
Q
;
ITEM(CIEN) ; EP - ENTER/EDIT ITEMS FOR A SPECIFIC CATEGORY
N DIC,DIK,DIR,DA,X,Y,Z,%,TUNIT,FLAG
I AGE S TUNIT=" "_$P($G(^VEN(7.11,CIEN,0)),U,10)
LOOP W !!,"What do you want to do next ->"
W !,?3,"1. Add an item"
W !,?3,"2. Edit an existing item"
W !,?3,"3. Delete an item"
W !,?3,"4. Quit"
S DIR(0)="N^1:4:0",DIR("A")="Your choice",DIR("B")="1" D ^DIR
I Y=4!('Y) D ^XBFMK Q ; QUIT
I Y=2 S FLAG="EDIT"
I Y=3 S FLAG="DELETE"
I Y=1 S FLAG="ADD" S IIEN=$$ADD(CIEN) G:'IIEN LOOP D EDIT(IIEN) G LOOP ; KEEP LOOPING
;
LOOKUP S DIC="^VEN(7.12,",DIC(0)="AEQM"
S DIC("A")="Item: "
S DIC("S")="I +^(0)=CIEN"
S %="W "": "",$P($G(^VEN(7.12,Y,0)),U,2)"
I AGE S %=%_","" (Age: "",$P($G(^VEN(7.12,Y,0)),U,13),""-"",$P($G(^VEN(7.12,Y,0)),U,14),$G(TUNIT),"")"""
S DIC("W")=%
D ^DIC I Y=-1 D ^XBFMK G LOOP
K DIC S IIEN=+Y
I FLAG="EDIT" D EDIT G LOOP
DELETE W !,"Are you sure you want to delete the item"
S %=2 D YN^DICN
I %'=1 W ! G M1
S DIK="^VEN(7.12,",DA=IIEN D ^DIK
W !," *** ITEM DELETED ***",!
G LOOP
;
EDIT(DA) ; EP - EDIT AN ITEM
N DIE,DR,X,Y,Z,%
S DIE="^VEN(7.12,"
S DR=""
I AGE D
. S DR=".02Item name"
. D ^DIE
. I '$L($P($G(^VEN(7.12,DA,0)),U,2)) Q ; REQUIRED FIELD
. S DR=".04Code;.1Gender screen;.13Starting age (mos);.14Ending age (mos)"
. D ^DIE
. Q
I $D(^VEN(7.12,DA,0)),'$L($P($G(^(0)),U,2)) S DIK="^VEN(7.12," D ^DIK ; REQUIRED FIELD
D ^XBFMK
Q
;
ADD(CIEN) ; EP - ADD A NEW ITEM
N DIC,X,Y,%
S DIC="^VEN(7.12,",DIC(0)="L",DLAYGO=19707.12
S X="""`"_CIEN_""""
D ^DIC
I Y=-1 Q ""
Q +Y
;
;
; --------------------------------------------------------
;
TADD(OUT,IN) ; EP - ADD A KB TO ONE OR MORE TEMPLATES
S OUT="UPDATE FAILED!"
S IN=$G(IN) I '$L(IN) Q
N KIEN,TSTG,TIEN,DIC,DA,X,Y,%,PCE,LEN
S KIEN=+IN I '$D(^VEN(7.11,KIEN,0)) Q
S DIC(0)="L",DLAYGO=19707.4116
S DIC("P")="19707.4116P"
S X="`"_KIEN
S TSTG=$P(IN,";",2) S LEN=$L(TSTG,",")
F PCE=1:1:LEN D
. S DA(1)=$P(TSTG,",",PCE)
. I '$D(^VEN(7.41,DA(1),0)) Q
. S DIC="^VEN(7.41,"_DA(1)_",16,"
. D ^DIC I Y=-1 Q
. Q
D ^XBFMK
S OUT="TEMPLATE FILE(S) UPDATED SUCCESSFULLY!"
Q
;
TREM(OUT,IN) ; EP - REMOVE A KB FROM ONE OR MORE TEMPLATES
S OUT="UNABLE TO REMOVE KB FROM TEMPLATE(S)!"
S IN=$G(IN) I '$L(IN) Q
N KIEN,TSTG,TIEN,DIK,DA,X,Y,%,PCE,LEN
S KIEN=+IN I '$D(^VEN(7.11,KIEN,0)) Q
S TSTG=$P(IN,";",2) S LEN=$L(TSTG,",")
F PCE=1:1:LEN D
. S DA(1)=$P(TSTG,",",PCE)
. I '$D(^VEN(7.41,DA(1),0)) Q
. S DIK="^VEN(7.41,"_DA(1)_",16,"
. S DA=$O(^VEN(7.41,DA(1),16,"B",KIEN,0)) I 'DA Q
. D ^DIK I Y=-1 Q
. Q
D ^XBFMK
S OUT="KB REMOVED SUCCESSFULLY!"
Q
;
; --------------------------------------------------------
;
KBG(OUT,IN) ; EP - RPC: VEN PCC+ GET KB GROUPS
S OUT="BMX ADO SS^VEN KB CATEGORY^^B~~~999999"
Q
;
KBI(OUT,IN) ; EP-SUBMIT KB GROUP AND RETURN ALL THE ITEMS IN A TABLE
S OUT=""
I '$L(IN) Q
N DIC,X,KGIEN,KIEN,DA
S KGIEN=$O(^VEN(7.11,"B",IN,0))
I 'KGIEN D ; NEED TO ADD NEW GROUP
. S DIC="^VEN(7.11,",DOC(0)="L"
. S DLAYGO=19707.11 S X=IN
. D ^DIC I Y=-1 Q
. S KGIEN=+Y
. Q
D ^XBFMK
I 'KGIEN Q
S OUT="BMX ADO SS^VEN KB ITEM^^B~"_KGIEN_"~"_KGIEN_"~999999"
Q
;
TAX(OUT,IN) ; EP - RPC: VEN PCC+ KB TAXONOMY
S OUT="BMX ADO SS^VEN KB TAXONOMY^^~~~~~ITAX~VENPCCK~" ; RETURN ALL TAXONOMIES
Q
;
KBT1(OUT,IN) ; EP - RPC: VEN PCC+ GET KB TEMPLATES
I $G(IN)="" S OUT="" Q ; INVALID KB GROUP
S OUT="BMX ADO SS^VEN KB TEMPLATES^^~~~~~FKBT~VENPCCK~"_IN ; RETURN ALL TEMPLATES ASSOC W KB GRP
Q
;
KBT2(OUT,IN) ; EP - RPC: VEN PCC+ GET NON KB TEMPLATES
I $G(IN)="" S OUT="" Q ; INVALID KB GROUP
S OUT="BMX ADO SS^VEN KB TEMPLATES^^~~~~~NKBT~VENPCCK~"_IN ; RETURN ALL TEMPLATES NOT ASSOC W KB GRP
Q
;
; ------------------------------------------------------------------
;
ITAX(PARAM,IENS,MAX,OUT,TOT) ; EP - RETURN A LIST OF TEMPLATES ASSOCIATED WITH A KB GROUP
N NAME,DA,STG
S NAME=""
F S NAME=$O(^ATXAX("B",NAME)) Q:NAME="" D
. S DA=0
. F S DA=$O(^ATXAX("B",NAME,DA)) Q:'DA D
.. I $P($G(^ATXAX(DA,0)),U,15)'=80 Q ; MUST BE AN ICD TAXONOMY
.. X ("D DATA"_$C(94)_"BMXADOV1(IENS,DA)")
.. Q
. Q
Q ""
;
FKBT(KGIEN,IENS,MAX,OUT,TOT) ; EP - RETURN A LIST OF TEMPLATES ASSOCIATED WITH A KB GROUP
N MODE S MODE=1
D FKBTX
Q ""
;
NKBT(KGIEN,IENS,MAX,OUT,TOT) ; EP - RETURN A LIST OF TEMPLATES THAT ARE NOT ASSOCIATED WITH A KB GROUP
N MODE S MODE=0
D FKBTX
Q ""
;
FKBTX ; FILTERS
N NAME,DA,STG
I '$D(^VEN(7.11,+$D(KGIEN),0)) Q
S NAME=""
F S NAME=$O(^VEN(7.41,"B",NAME)) Q:NAME="" D
. S DA=0
. F S DA=$O(^VEN(7.41,"B",NAME,DA)) Q:'DA D
.. I MODE,'$O(^VEN(7.41,DA,16,"B",KGIEN,0)) Q ; FILTER OUT FORM IF IT IS NOT ASSOCIATED WITH THIS KB GROUP
.. I 'MODE,$O(^VEN(7.41,DA,16,"B",KGIEN,0)) Q ; FILTER OUT FORM IF IT IS NOT ASSOCIATED WITH THIS KB GROUP
.. D DATA^BMXADOV1(IENS,DA)
.. Q
. Q
Q
;
KBT3(OUT,IN) ; EP-ASSOCIATE KB GROUP WITH TEMPLATES
N DIC,X,Y,DA,STG,PCE,KB
S KB=+$G(IN) I '$D(^VEN(7.11,KB,0)) Q ""
S DIC("P")="19707.4116P" S DIC(0)="L" S DLAYGO=19707.4116
S STG=$P(IN,";",2)
F PCE=1:1:$L(STG,",") D
. S DA(1)=$P(STG,",",PCE)
. S X="`"_KB
. I '$D(^VEN(7.41,DA(1))) Q
. S DIC="^VEN(7.41,"_DA(1)_",16,"
. D ^DIC
. Q
S OUT="OK" D ^XBFMK
Q
;
VENPCCK1 ; IHS/OIT/GIS - KNOWLEDGE BASE ;
+1 ;;2.6;PCC+;;NOV 12, 2007
+2 ; RPMS DIALOGUE
+3 ;
+4 ;
AGE ; EP - DIALOGUE FOR AGE-SEX SPECIFIC ITEMS
+1 NEW AGE
+2 SET AGE=1
+3 DO CAT
+4 QUIT
+5 ;
CAT ; EP - GET THE KB CATEGORY
+1 NEW DIC,X,Y,Z,%,CIEN,IIEN,DIR,DA,DIK,%Y
+2 SET DIC("A")="Enter the name of the knowledgebase category: "
+3 SET DIC="^VEN(7.11,"
SET DIC(0)="AEQML"
SET DLAYGO=19707.11
+4 DO ^DIC
IF Y=-1
DO ^XBFMK
QUIT
+1 SET CIEN=+Y
+2 IF $PIECE(Y,U,3)
DO ITEM(CIEN)
QUIT
M1 WRITE !!,"What do you want to do next ->"
+1 WRITE !,?3,"1. Add or edit items in this category."
+2 WRITE !,?3,"2. Delete this KB category."
+3 WRITE !,?3,"3. Quit."
+4 SET DIR(0)="N^1:3:0"
SET DIR("A")="Your choice"
SET DIR("B")="1"
DO ^DIR
+5 IF Y=1
DO ITEM(CIEN)
QUIT
+6 IF Y=3!('Y)
DO ^XBFMK
QUIT
+7 IF Y=2
WRITE !!,"This will DELETE the category and all items associated with it!!!"
+8 WRITE !,"Are you sure you want to do this"
+9 SET %=2
DO YN^DICN
+10 IF %'=1
WRITE !
GOTO M1
+11 SET DIK="^VEN(7.11,"
SET DA=CIEN
DO ^DIK
+12 SET DA=0
SET DIK="^VEN(7.12,"
+13 ; CLEAN OUT THE ASSOCIATED ITEMS
FOR
SET DA=$ORDER(^VEN(7.12,"B",CIEN,DA))
IF 'DA
QUIT
DO ^DIK
+14 WRITE !," *** CATEGORY DELETED ***"
+15 DO ^XBFMK
+16 QUIT
+17 ;
ITEM(CIEN) ; EP - ENTER/EDIT ITEMS FOR A SPECIFIC CATEGORY
+1 NEW DIC,DIK,DIR,DA,X,Y,Z,%,TUNIT,FLAG
+2 IF AGE
SET TUNIT=" "_$PIECE($GET(^VEN(7.11,CIEN,0)),U,10)
LOOP WRITE !!,"What do you want to do next ->"
+1 WRITE !,?3,"1. Add an item"
+2 WRITE !,?3,"2. Edit an existing item"
+3 WRITE !,?3,"3. Delete an item"
+4 WRITE !,?3,"4. Quit"
+5 SET DIR(0)="N^1:4:0"
SET DIR("A")="Your choice"
SET DIR("B")="1"
DO ^DIR
+6 ; QUIT
IF Y=4!('Y)
DO ^XBFMK
QUIT
+7 IF Y=2
SET FLAG="EDIT"
+8 IF Y=3
SET FLAG="DELETE"
+9 ; KEEP LOOPING
IF Y=1
SET FLAG="ADD"
SET IIEN=$$ADD(CIEN)
IF 'IIEN
GOTO LOOP
DO EDIT(IIEN)
GOTO LOOP
+10 ;
LOOKUP SET DIC="^VEN(7.12,"
SET DIC(0)="AEQM"
+1 SET DIC("A")="Item: "
+2 SET DIC("S")="I +^(0)=CIEN"
+3 SET %="W "": "",$P($G(^VEN(7.12,Y,0)),U,2)"
+4 IF AGE
SET %=%_","" (Age: "",$P($G(^VEN(7.12,Y,0)),U,13),""-"",$P($G(^VEN(7.12,Y,0)),U,14),$G(TUNIT),"")"""
+5 SET DIC("W")=%
+6 DO ^DIC
IF Y=-1
DO ^XBFMK
GOTO LOOP
+7 KILL DIC
SET IIEN=+Y
+8 IF FLAG="EDIT"
DO EDIT
GOTO LOOP
DELETE WRITE !,"Are you sure you want to delete the item"
+1 SET %=2
DO YN^DICN
+2 IF %'=1
WRITE !
GOTO M1
+3 SET DIK="^VEN(7.12,"
SET DA=IIEN
DO ^DIK
+4 WRITE !," *** ITEM DELETED ***",!
+5 GOTO LOOP
+6 ;
EDIT(DA) ; EP - EDIT AN ITEM
+1 NEW DIE,DR,X,Y,Z,%
+2 SET DIE="^VEN(7.12,"
+3 SET DR=""
+4 IF AGE
Begin DoDot:1
+5 SET DR=".02Item name"
+6 DO ^DIE
+7 ; REQUIRED FIELD
IF '$LENGTH($PIECE($GET(^VEN(7.12,DA,0)),U,2))
QUIT
+8 SET DR=".04Code;.1Gender screen;.13Starting age (mos);.14Ending age (mos)"
+9 DO ^DIE
+10 QUIT
End DoDot:1
+11 ; REQUIRED FIELD
IF $DATA(^VEN(7.12,DA,0))
IF '$LENGTH($PIECE($GET(^(0)),U,2))
SET DIK="^VEN(7.12,"
DO ^DIK
+12 DO ^XBFMK
+13 QUIT
+14 ;
ADD(CIEN) ; EP - ADD A NEW ITEM
+1 NEW DIC,X,Y,%
+2 SET DIC="^VEN(7.12,"
SET DIC(0)="L"
SET DLAYGO=19707.12
+3 SET X="""`"_CIEN_""""
+4 DO ^DIC
+5 IF Y=-1
QUIT ""
+6 QUIT +Y
+7 ;
+8 ;
+9 ; --------------------------------------------------------
+10 ;
TADD(OUT,IN) ; EP - ADD A KB TO ONE OR MORE TEMPLATES
+1 SET OUT="UPDATE FAILED!"
+2 SET IN=$GET(IN)
IF '$LENGTH(IN)
QUIT
+3 NEW KIEN,TSTG,TIEN,DIC,DA,X,Y,%,PCE,LEN
+4 SET KIEN=+IN
IF '$DATA(^VEN(7.11,KIEN,0))
QUIT
+5 SET DIC(0)="L"
SET DLAYGO=19707.4116
+6 SET DIC("P")="19707.4116P"
+7 SET X="`"_KIEN
+8 SET TSTG=$PIECE(IN,";",2)
SET LEN=$LENGTH(TSTG,",")
+9 FOR PCE=1:1:LEN
Begin DoDot:1
+10 SET DA(1)=$PIECE(TSTG,",",PCE)
+11 IF '$DATA(^VEN(7.41,DA(1),0))
QUIT
+12 SET DIC="^VEN(7.41,"_DA(1)_",16,"
+13 DO ^DIC
IF Y=-1
QUIT
+14 QUIT
End DoDot:1
+15 DO ^XBFMK
+16 SET OUT="TEMPLATE FILE(S) UPDATED SUCCESSFULLY!"
+17 QUIT
+18 ;
TREM(OUT,IN) ; EP - REMOVE A KB FROM ONE OR MORE TEMPLATES
+1 SET OUT="UNABLE TO REMOVE KB FROM TEMPLATE(S)!"
+2 SET IN=$GET(IN)
IF '$LENGTH(IN)
QUIT
+3 NEW KIEN,TSTG,TIEN,DIK,DA,X,Y,%,PCE,LEN
+4 SET KIEN=+IN
IF '$DATA(^VEN(7.11,KIEN,0))
QUIT
+5 SET TSTG=$PIECE(IN,";",2)
SET LEN=$LENGTH(TSTG,",")
+6 FOR PCE=1:1:LEN
Begin DoDot:1
+7 SET DA(1)=$PIECE(TSTG,",",PCE)
+8 IF '$DATA(^VEN(7.41,DA(1),0))
QUIT
+9 SET DIK="^VEN(7.41,"_DA(1)_",16,"
+10 SET DA=$ORDER(^VEN(7.41,DA(1),16,"B",KIEN,0))
IF 'DA
QUIT
+11 DO ^DIK
IF Y=-1
QUIT
+12 QUIT
End DoDot:1
+13 DO ^XBFMK
+14 SET OUT="KB REMOVED SUCCESSFULLY!"
+15 QUIT
+16 ;
+17 ; --------------------------------------------------------
+18 ;
KBG(OUT,IN) ; EP - RPC: VEN PCC+ GET KB GROUPS
+1 SET OUT="BMX ADO SS^VEN KB CATEGORY^^B~~~999999"
+2 QUIT
+3 ;
KBI(OUT,IN) ; EP-SUBMIT KB GROUP AND RETURN ALL THE ITEMS IN A TABLE
+1 SET OUT=""
+2 IF '$LENGTH(IN)
QUIT
+3 NEW DIC,X,KGIEN,KIEN,DA
+4 SET KGIEN=$ORDER(^VEN(7.11,"B",IN,0))
+5 ; NEED TO ADD NEW GROUP
IF 'KGIEN
Begin DoDot:1
+6 SET DIC="^VEN(7.11,"
SET DOC(0)="L"
+7 SET DLAYGO=19707.11
SET X=IN
+8 DO ^DIC
IF Y=-1
QUIT
+9 SET KGIEN=+Y
+10 QUIT
End DoDot:1
+11 DO ^XBFMK
+12 IF 'KGIEN
QUIT
+13 SET OUT="BMX ADO SS^VEN KB ITEM^^B~"_KGIEN_"~"_KGIEN_"~999999"
+14 QUIT
+15 ;
TAX(OUT,IN) ; EP - RPC: VEN PCC+ KB TAXONOMY
+1 ; RETURN ALL TAXONOMIES
SET OUT="BMX ADO SS^VEN KB TAXONOMY^^~~~~~ITAX~VENPCCK~"
+2 QUIT
+3 ;
KBT1(OUT,IN) ; EP - RPC: VEN PCC+ GET KB TEMPLATES
+1 ; INVALID KB GROUP
IF $GET(IN)=""
SET OUT=""
QUIT
+2 ; RETURN ALL TEMPLATES ASSOC W KB GRP
SET OUT="BMX ADO SS^VEN KB TEMPLATES^^~~~~~FKBT~VENPCCK~"_IN
+3 QUIT
+4 ;
KBT2(OUT,IN) ; EP - RPC: VEN PCC+ GET NON KB TEMPLATES
+1 ; INVALID KB GROUP
IF $GET(IN)=""
SET OUT=""
QUIT
+2 ; RETURN ALL TEMPLATES NOT ASSOC W KB GRP
SET OUT="BMX ADO SS^VEN KB TEMPLATES^^~~~~~NKBT~VENPCCK~"_IN
+3 QUIT
+4 ;
+5 ; ------------------------------------------------------------------
+6 ;
ITAX(PARAM,IENS,MAX,OUT,TOT) ; EP - RETURN A LIST OF TEMPLATES ASSOCIATED WITH A KB GROUP
+1 NEW NAME,DA,STG
+2 SET NAME=""
+3 FOR
SET NAME=$ORDER(^ATXAX("B",NAME))
IF NAME=""
QUIT
Begin DoDot:1
+4 SET DA=0
+5 FOR
SET DA=$ORDER(^ATXAX("B",NAME,DA))
IF 'DA
QUIT
Begin DoDot:2
+6 ; MUST BE AN ICD TAXONOMY
IF $PIECE($GET(^ATXAX(DA,0)),U,15)'=80
QUIT
+7 XECUTE ("D DATA"_$CHAR(94)_"BMXADOV1(IENS,DA)")
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 QUIT ""
+11 ;
FKBT(KGIEN,IENS,MAX,OUT,TOT) ; EP - RETURN A LIST OF TEMPLATES ASSOCIATED WITH A KB GROUP
+1 NEW MODE
SET MODE=1
+2 DO FKBTX
+3 QUIT ""
+4 ;
NKBT(KGIEN,IENS,MAX,OUT,TOT) ; EP - RETURN A LIST OF TEMPLATES THAT ARE NOT ASSOCIATED WITH A KB GROUP
+1 NEW MODE
SET MODE=0
+2 DO FKBTX
+3 QUIT ""
+4 ;
FKBTX ; FILTERS
+1 NEW NAME,DA,STG
+2 IF '$DATA(^VEN(7.11,+$DATA(KGIEN),0))
QUIT
+3 SET NAME=""
+4 FOR
SET NAME=$ORDER(^VEN(7.41,"B",NAME))
IF NAME=""
QUIT
Begin DoDot:1
+5 SET DA=0
+6 FOR
SET DA=$ORDER(^VEN(7.41,"B",NAME,DA))
IF 'DA
QUIT
Begin DoDot:2
+7 ; FILTER OUT FORM IF IT IS NOT ASSOCIATED WITH THIS KB GROUP
IF MODE
IF '$ORDER(^VEN(7.41,DA,16,"B",KGIEN,0))
QUIT
+8 ; FILTER OUT FORM IF IT IS NOT ASSOCIATED WITH THIS KB GROUP
IF 'MODE
IF $ORDER(^VEN(7.41,DA,16,"B",KGIEN,0))
QUIT
+9 DO DATA^BMXADOV1(IENS,DA)
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
KBT3(OUT,IN) ; EP-ASSOCIATE KB GROUP WITH TEMPLATES
+1 NEW DIC,X,Y,DA,STG,PCE,KB
+2 SET KB=+$GET(IN)
IF '$DATA(^VEN(7.11,KB,0))
QUIT ""
+3 SET DIC("P")="19707.4116P"
SET DIC(0)="L"
SET DLAYGO=19707.4116
+4 SET STG=$PIECE(IN,";",2)
+5 FOR PCE=1:1:$LENGTH(STG,",")
Begin DoDot:1
+6 SET DA(1)=$PIECE(STG,",",PCE)
+7 SET X="`"_KB
+8 IF '$DATA(^VEN(7.41,DA(1)))
QUIT
+9 SET DIC="^VEN(7.41,"_DA(1)_",16,"
+10 DO ^DIC
+11 QUIT
End DoDot:1
+12 SET OUT="OK"
DO ^XBFMK
+13 QUIT
+14 ;
