VENPCCC ; IHS/OIT/GIS - CHECK LIST MANAGEMENT ;
;;2.6;PCC+;;NOV 12, 2007
;
;
;
POP(DEFEF,DFN) ; EP - POPULATE CHECKLIST ITEM MM FIELDS
N DEMO,GIEN,IIEN,STG,MM,C1,C2,TMP,GRP,CKIEN,DOB,SEX,AGE,CAT,LIEN,OGIEN,MN,CNT,FLD,NAME,PRE,POST
S TMP=$NA(^TMP("VEN PRNT",$J,1))
I '$O(^VEN(7.41,+$G(DEFEF),17,0)) Q ; NO CHECKLISTS ASSOCIATED WITH THIS FORM
S DEMO=$G(^DPT(+$G(DFN),0)) I '$L(DEMO) Q
S SEX=$P(DEMO,U,2) I SEX'="M",SEX'="F" Q
S DOB=$P(DEMO,U,3) I 'DOB Q
S AGE=DT-DOB\10000
S GRP=$S(AGE<2:1,AGE<13:2,SEX="M":3,1:4)
S GIEN=0
F S GIEN=$O(^VEN(7.41,DEFEF,17,GIEN)) Q:'GIEN D
. S LIEN=$P($G(^VEN(7.41,DEFEF,17,GIEN,0)),U) I 'LIEN Q ; CKLIST SUBFILE IEN
. S %=$G(^VEN(7.9,LIEN,0)) I '$L(%) Q ; PATCHED GIS/OIT 10/4/2005 ; CHECKLIST FILE ; PCC+ 2.5 PATCH 1
. S OGIEN=$P(%,U,2) I 'OGIEN Q ; CHECKLIST CATEGORY
. S PRE=$P(%,U,3) S POST=$P(%,U,4) ; PRE AND POST NOW ASSOCIATED WITH THE CHECKLIST - NOT THE ITEM
. S MN=$P($G(^VEN(7.98,OGIEN,0)),U,3) I MN="" Q ; MAIL MERGE MNEMONIC
. S IIEN=0 S CNT=0
. F S IIEN=$O(^VEN(7.91,"AB",LIEN,IIEN)) Q:'IIEN D
.. S STG=$G(^VEN(7.91,IIEN,0)) I STG="" Q
.. I '$P(STG,U,GRP+2) Q ; CK GROUP
.. S NAME=$P(STG,U) I NAME="" Q
.. S C1=$P(STG,U,7) S C2=$P(STG,U,8)
.. S PRE=$P(STG,U,9),POST=$P(STG,U,10)
.. S CNT=CNT+1
.. S FLD=MN_CNT S @TMP@(FLD)=PRE_NAME_POST ; CHECKLIST ITEM
.. I $L(C1) S FLD=MN_CNT_"a" S @TMP@(FLD)=C1 ; PRIMARY CODE - TYPICALLY THE CPT
.. I $L(C2) S FLD=FLD_CNT_"x" S @TMP@(FLD)=C2 ; SECONDARY CODE
.. Q
. Q
Q
;
CONVERT ; EP-CONVERT ORDERABLE SETS/GROUPS TO CHECK LISTS
I '$O(^VEN(7.9,0)),'$O(^VEN(7.91,0)) ; MAKE SURE THAT THIS IS A VIRGIN CONVERSION
E W !,"Conversion has already been completed! Request cancelled..." Q
N SIEN,SET,%,%Y
W "Want to convert order sets and orderables to checklists and items"
S %=1 D YN^DICN
I %'=1 W !,"Request cancelled..." Q
I '$O(^VEN(7.92,0)) S SET="GENERIC CHECK LIST",SIEN="" D CKLIST(SET,SIEN) I 1 ; ORDER SETS HAVE NOT BEEN SET UP YET
E S SIEN=0 F S SIEN=$O(^VEN(7.92,SIEN)) Q:'SIEN S SET=$P($G(^VEN(7.92,SIEN,0)),U) I $L(SET) D CKLIST(SET,SIEN)
D ITEMS
S DIE="^VEN(7.5," S DA=$$CFG^VENPCCU S DR=".17////1"
L +^VEN(7.5,DA):0 I $T D ^DIE L -^VEN(7.5,DA) ; SET THE "USE CHECKLIST" PARAMETER IN THE CONFIG FILE
I $O(^VEN(7.91,0)) W !,"Orderables have been successfully converted to checklist items!"
E D ^XBFMK Q
S DA=$O(^DIC(19,"B","VEN CL INITIALIZE CHECKLISTS",0)) I 'DA D ^XBFMK Q
S DIE="^DIC(19,",DR="2////Conversion completed..." ; OUT OF ORDER MESSAGE
L +^DIC(19,DA):0 I $T D ^DIE L -^DIC(19,DA)
D ^XBFMK
Q
;
CKLIST(SET,SIEN) ; EP-POPULATE THE CHECKLIST FILE
N DIC,GIEN,GROUP,X,Y,%,GMN,LIST,TYPE,TIEN,OSIEN,GSTG,PCE
S DIC="^VEN(7.9,",DLAYGO=19707.9
S DIE=DIC
S DR=".02///^S X=TYPE"
S GIEN=0 S GSTG=""
F S GIEN=$O(^VEN(7.98,GIEN)) Q:'GIEN D ; WITHIN EACH SET, GET ALL ORDERABLE GROUPS
. S %=$G(^VEN(7.98,GIEN,0)) I '$L(%) Q
. S GMN=$P(%,U,2) I '$L(GMN) Q
. I GMN'="HMR",GMN'="EDU" ; REMINDERS AND PT ED TOPICS ARE NOW HANDLED ELSEWHERE
. E Q
. S LIST=SET_" ("_GMN_")"
. S X=LIST S DIC(0)="L"
. D ^DIC I Y=-1 Q ; SET X GROUP = CHECKLIST
. S DA=+Y
. S TYPE="`"_GIEN
. L +^VEN(7.9,DA):0 I $T D ^DIE L -^VEN(7.9,DA)
. S:$L(GSTG) GSTG=GSTG_U
. S GSTG=GSTG_GIEN ; THE GSTG CONTAINS THE IENS OF ALL ORDERABLE GROUPS
. Q
I $L(GSTG) D TEMPLATE(SIEN,GSTG) ; REGISER THE NEW CKLISTS IN THE APPROPRIATE TEMPLATE FILES
Q
;
TEMPLATE(SIEN,GSTG) ; EP-POPULATE THE CHECKLIST SUBFILE IN THE VEN EHP EF TEMPLATES FILE
; IF THE TEMPLATE CONTAINS THE ORDER SET, ADD ALL THE ORDER GROUPS TO THE CHECKLIST MULTIPLE
N DA,DIC,DIE,DR,OSIEN,TIEN,X,PCE
S TIEN=0,SIEN=$G(SIEN)
F S TIEN=$O(^VEN(7.41,TIEN)) Q:'TIEN D ; POPULATE THE TEMPLATE FILE
. S OSIEN=$P($G(^VEN(7.41,TIEN,0)),U,9)
. I OSIEN'=SIEN Q ; MUST BE A MATCH (OR IF BOTH ARE BLANK)
. S DA(1)=TIEN,DIC(0)="L",DLAYGO=19707.4117
. S DIC="^VEN(7.41,"_DA(1)_",17,",DIC("P")="19707.4117P"
. F PCE=1:1:$L(GSTG,U) D
.. S X=$P(GSTG,U,PCE) I 'X Q
.. S X="`"_X
.. D ^DIC ; ADD CHECK LISTS TO THE SUBFILE
.. Q
. Q
Q
;
ITEMS ; EP-CONVERT ORDERABLES TO CHECKLIST ITEMS
; GO THRU ALL THE ORDERABLES, CONVERT EACH TO A CHECKLIST ITEM
N GIEN,GRP,CKIEN,IGRP,OIEN,%,CAT,MMMN,PMN,ONAME,STG,SIEN,SNAME,CNAME,C1,C2,MN,NAME,PRE,POST
N DIC,DIE,DR,DA,X,Y
S GIEN=0
MNIX F S GIEN=$O(^VEN(7.98,GIEN)) Q:'GIEN D ; MAKE INDEX FOR MAIL MERGE/PREFERENCE MNEMONICS
. S MMMN=$P($G(^VEN(7.98,GIEN,0)),U,3) ; MAIL MERGE MNEMONIC
. I '$L(MMMN) Q
. I MMMN'="y",MMMN'="h"
. E Q
. S PMN=$P(^VEN(7.98,GIEN,0),U,2) ; PREFERENCE MNEMONIC
. I '$L(PMN) Q
. S MN(MMMN)=PMN
. Q
COI ; CONVERT ORDERABLES TO ITEMS
S (DIC,DIE)="^VEN(7.91,",DIC(0)="LX",DLAYGO=19707.91
S ONAME="" F S ONAME=$O(^VEN(7.93,"B",ONAME)) Q:ONAME="" S OIEN=$O(^VEN(7.93,"B",ONAME,0)) I OIEN D
. S STG=$G(^VEN(7.93,OIEN,0)) I '$L(STG) Q
. S SIEN=+$P(STG,U,2) I 'SIEN S SNAME="GENERIC CHECK LIST"
. E S SNAME=$P($G(^VEN(7.92,SIEN,0)),U) I '$L(SNAME) Q
. S CAT=$P(STG,U,10) I CAT="" Q
. S MMMN=$E(CAT,2) I MMMN="" Q
. S GRP=+CAT I GRP,GRP=GRP\1,GRP>0,GRP<5
. E Q
. S PMN=$G(MN(MMMN)) I PMN="" Q
. S CNAME=SNAME_" ("_PMN_")"
. S CKIEN=$O(^VEN(7.9,"B",CNAME,0)) I 'CKIEN Q
. S C1=$P(STG,U,6) S C2=$P(STG,U,7) ; CODES
. S PRE="",POST="",NAME=ONAME
. S %=$E(NAME) I %="_"!(%=" ") D ; GET PRE STRING
.. F I=1:1:$L(NAME) Q:$E(NAME,I)?1A
.. S PRE=$E(NAME,1,I-1) S NAME=$E(NNAME,I,999)
.. Q
. S %=$E(NAME,$L(NAME)) I %="_"!(%=" ") D
.. S %=$L(NAME)
.. F I=%:-1:1 Q:$E(NAME,I)?1A
.. S POST=$E(NAME,I+1,%) S NAME=$E(NAME,1,I)
.. Q
. S X=$$NAME(NAME) ; STANDARDIZE NAME WITH CAPS
. D ^DIC I Y=-1 Q
. S DA=+Y
. D CSUB(CKIEN,DA) ; POPULATE THE CHECKLIST MULTIPLE
. S DR=$$DR(DA,GRP,C1,C2,CKIEN) I DR="" Q ; MAKE DR STRING
. L +^VEN(7.91,DA):0 I $T D ^DIE L -^VEN(7.91,DA)
. F S OIEN=$O(^VEN(7.93,"B",ONAME,OIEN)) Q:'OIEN D ; UPDATE ITEM WITH THE OTHER ENTRIES OF THE SAME NAME
.. S %=$G(^VEN(7.93,OIEN,0)) I '$L(%) Q
.. S CAT=$P(%,U,10) I CAT="" Q
.. S GRP=+CAT I GRP,GRP=GRP\1,GRP>0,GRP<5
.. E Q
.. S C1=$P(%,U,6) S C2=$P(%,U,7)
.. I PRE="" S PRE=$P(%,U,4)
.. S PRE=$E(PRE,1,9) S POST=$E(POST,1,9)
.. S DR=$$DR(DA,GRP,C1,C2,CKIEN,PRE,POST) I DR="" Q
.. L +^VEN(7.91,DA):0 I $T D ^DIE L -^VEN(7.91,DA)
.. Q
. Q
D ^XBFMK
Q
;
NAME(NAME) ; EP - CAPITALIZE THE 1ST LETTER OF EVERY WORD
N L,I,F,X,Y,A
I '$L($G(NAME)) Q ""
I NAME?1.U Q NAME
S NAME=$$LOW^XLFSTR(NAME),A=""
S L=$L(NAME),F=0,Y=1
F I=1:1:L S X=$E(NAME,I) D
. I Y,X?1L S Y=0,X=$$UP^XLFSTR(X),A=A_X Q ; CAP THE IST LETTER
. I X=" " S F=1,A=A_X Q
. I F,X?1L S F=0,X=$$UP^XLFSTR(X) ; CAP THE IT LETTER AFTER A SPACE
. S A=A_X
. Q
Q A
;
CSUB(X,Y) ; EP - MAKE ENTRY IN CHECKIN GROUP SUBFILE
N DIC,DIE,DA,DR
I '$D(^VEN(7.9,+$G(X),0)) Q
I '$G(Y) Q
S DA(1)=Y
S DIC="^VEN(7.91,"_DA(1)_",2,"
S DIC(0)="L",DIC("P")="19707.912P",DLAYGO=19707.912
S X="`"_X
D ^DIC
D ^XBFMK
Q
;
DR(DA,GRP,C1,C2,CKIEN,PRE,POST) ; EP - MAKE DR STG
N DR,STG
S %=$G(GRP) I '% Q
S DR=".0"_(%+2)_"////1"
S STG=$G(^VEN(7.91,+$G(DA),0)) I STG="" Q
I $D(^VEN(7.9,+$G(CKIEN),0)) D ; SET PROPERTIES RELATED TO THE CHECKLIST
. I $P(STG,U,2)="" S DR=DR_";.02////"_CKIEN
. I $L($G(PRE)),$P(^VEN(7.9,CKIEN,0),U,3)="" S $P(^(0),U,3)=PRE ; SET PRE FOR THE CHECKLIST - IF NECESSARY
. I $L($G(POST)),$P(^VEN(7.9,CKIEN,0),U,4)="" S $P(^(0),U,4)=POST ; SET POST FOR THE CHECKLIST - IF NECESSARY
. Q
I $L($G(C1)),$P(STG,U,7)="",C1'[":",C1'[";" S DR=DR_";.07////"_C1
I $L($G(C2)),$P(STG,U,8)="",C2'[":",C2'[";" S DR=DR_";.08////"_C2
Q DR
;
MM(DA) ; EP - COMPUTE MM FIELD VALUE
N GIEN,IEN,CNT,MM
S MM=""
S GIEN=$P($G(^VEN(7.91,+$G(DA),0)),U,2) I 'GIEN Q MM
S MN=$P($G(^VEN(7.98,GIEN,0)),U,3) I '$L(MN) Q
S CNT=0,IEN=0
F S IEN=$O(^VEN(7.91,"AC",GIEN,IEN)) Q:'IEN S CNT=CNT+1 I IEN=DA Q
I 'CNT Q MM
S MM=MN_CNT
Q MM
;
CL(OUT,IN) ; EP - RPC: VEN PCC+ GET CL CATEGORIES
; RETURN THE ADO TEBLE GEN STRING TO VIEW CHECKLIST CATEGORIES
S OUT=""
Q
;
CLI(OUT,IN) ; EP - RPC: VNE PCC+ GET CL ITEMS
; RETURN THE ADO TEBLE GEN STRING TO VIEW CHECKLIST ITEMS
S OUT=""
I '$D(^VEN(7.9,+$G(IN),0)) Q
S OUT="BMX ADO SS^VEN CL ITEMS^^AB~"_IN_"~"_IN_"~999999"
Q
;
VENPCCC ; IHS/OIT/GIS - CHECK LIST MANAGEMENT ;
+1 ;;2.6;PCC+;;NOV 12, 2007
+2 ;
+3 ;
+4 ;
POP(DEFEF,DFN) ; EP - POPULATE CHECKLIST ITEM MM FIELDS
+1 NEW DEMO,GIEN,IIEN,STG,MM,C1,C2,TMP,GRP,CKIEN,DOB,SEX,AGE,CAT,LIEN,OGIEN,MN,CNT,FLD,NAME,PRE,POST
+2 SET TMP=$NAME(^TMP("VEN PRNT",$JOB,1))
+3 ; NO CHECKLISTS ASSOCIATED WITH THIS FORM
IF '$ORDER(^VEN(7.41,+$GET(DEFEF),17,0))
QUIT
+4 SET DEMO=$GET(^DPT(+$GET(DFN),0))
IF '$LENGTH(DEMO)
QUIT
+5 SET SEX=$PIECE(DEMO,U,2)
IF SEX'="M"
IF SEX'="F"
QUIT
+6 SET DOB=$PIECE(DEMO,U,3)
IF 'DOB
QUIT
+7 SET AGE=DT-DOB\10000
+8 SET GRP=$SELECT(AGE<2:1,AGE<13:2,SEX="M":3,1:4)
+9 SET GIEN=0
+10 FOR
SET GIEN=$ORDER(^VEN(7.41,DEFEF,17,GIEN))
IF 'GIEN
QUIT
Begin DoDot:1
+11 ; CKLIST SUBFILE IEN
SET LIEN=$PIECE($GET(^VEN(7.41,DEFEF,17,GIEN,0)),U)
IF 'LIEN
QUIT
+12 ; PATCHED GIS/OIT 10/4/2005 ; CHECKLIST FILE ; PCC+ 2.5 PATCH 1
SET %=$GET(^VEN(7.9,LIEN,0))
IF '$LENGTH(%)
QUIT
+13 ; CHECKLIST CATEGORY
SET OGIEN=$PIECE(%,U,2)
IF 'OGIEN
QUIT
+14 ; PRE AND POST NOW ASSOCIATED WITH THE CHECKLIST - NOT THE ITEM
SET PRE=$PIECE(%,U,3)
SET POST=$PIECE(%,U,4)
+15 ; MAIL MERGE MNEMONIC
SET MN=$PIECE($GET(^VEN(7.98,OGIEN,0)),U,3)
IF MN=""
QUIT
+16 SET IIEN=0
SET CNT=0
+17 FOR
SET IIEN=$ORDER(^VEN(7.91,"AB",LIEN,IIEN))
IF 'IIEN
QUIT
Begin DoDot:2
+18 SET STG=$GET(^VEN(7.91,IIEN,0))
IF STG=""
QUIT
+19 ; CK GROUP
IF '$PIECE(STG,U,GRP+2)
QUIT
+20 SET NAME=$PIECE(STG,U)
IF NAME=""
QUIT
+21 SET C1=$PIECE(STG,U,7)
SET C2=$PIECE(STG,U,8)
+22 SET PRE=$PIECE(STG,U,9)
SET POST=$PIECE(STG,U,10)
+23 SET CNT=CNT+1
+24 ; CHECKLIST ITEM
SET FLD=MN_CNT
SET @TMP@(FLD)=PRE_NAME_POST
+25 ; PRIMARY CODE - TYPICALLY THE CPT
IF $LENGTH(C1)
SET FLD=MN_CNT_"a"
SET @TMP@(FLD)=C1
+26 ; SECONDARY CODE
IF $LENGTH(C2)
SET FLD=FLD_CNT_"x"
SET @TMP@(FLD)=C2
+27 QUIT
End DoDot:2
+28 QUIT
End DoDot:1
+29 QUIT
+30 ;
CONVERT ; EP-CONVERT ORDERABLE SETS/GROUPS TO CHECK LISTS
+1 ; MAKE SURE THAT THIS IS A VIRGIN CONVERSION
IF '$ORDER(^VEN(7.9,0))
IF '$ORDER(^VEN(7.91,0))
+2 IF '$TEST
WRITE !,"Conversion has already been completed! Request cancelled..."
QUIT
+3 NEW SIEN,SET,%,%Y
+4 WRITE "Want to convert order sets and orderables to checklists and items"
+5 SET %=1
DO YN^DICN
+6 IF %'=1
WRITE !,"Request cancelled..."
QUIT
+7 ; ORDER SETS HAVE NOT BEEN SET UP YET
IF '$ORDER(^VEN(7.92,0))
SET SET="GENERIC CHECK LIST"
SET SIEN=""
DO CKLIST(SET,SIEN)
IF 1
+8 IF '$TEST
SET SIEN=0
FOR
SET SIEN=$ORDER(^VEN(7.92,SIEN))
IF 'SIEN
QUIT
SET SET=$PIECE($GET(^VEN(7.92,SIEN,0)),U)
IF $LENGTH(SET)
DO CKLIST(SET,SIEN)
+9 DO ITEMS
+10 SET DIE="^VEN(7.5,"
SET DA=$$CFG^VENPCCU
SET DR=".17////1"
+11 ; SET THE "USE CHECKLIST" PARAMETER IN THE CONFIG FILE
LOCK +^VEN(7.5,DA):0
IF $TEST
DO ^DIE
LOCK -^VEN(7.5,DA)
+12 IF $ORDER(^VEN(7.91,0))
WRITE !,"Orderables have been successfully converted to checklist items!"
+13 IF '$TEST
DO ^XBFMK
QUIT
+14 SET DA=$ORDER(^DIC(19,"B","VEN CL INITIALIZE CHECKLISTS",0))
IF 'DA
DO ^XBFMK
QUIT
+15 ; OUT OF ORDER MESSAGE
SET DIE="^DIC(19,"
SET DR="2////Conversion completed..."
+16 LOCK +^DIC(19,DA):0
IF $TEST
DO ^DIE
LOCK -^DIC(19,DA)
+17 DO ^XBFMK
+18 QUIT
+19 ;
CKLIST(SET,SIEN) ; EP-POPULATE THE CHECKLIST FILE
+1 NEW DIC,GIEN,GROUP,X,Y,%,GMN,LIST,TYPE,TIEN,OSIEN,GSTG,PCE
+2 SET DIC="^VEN(7.9,"
SET DLAYGO=19707.9
+3 SET DIE=DIC
+4 SET DR=".02///^S X=TYPE"
+5 SET GIEN=0
SET GSTG=""
+6 ; WITHIN EACH SET, GET ALL ORDERABLE GROUPS
FOR
SET GIEN=$ORDER(^VEN(7.98,GIEN))
IF 'GIEN
QUIT
Begin DoDot:1
+7 SET %=$GET(^VEN(7.98,GIEN,0))
IF '$LENGTH(%)
QUIT
+8 SET GMN=$PIECE(%,U,2)
IF '$LENGTH(GMN)
QUIT
+9 ; REMINDERS AND PT ED TOPICS ARE NOW HANDLED ELSEWHERE
IF GMN'="HMR"
IF GMN'="EDU"
+10 IF '$TEST
QUIT
+11 SET LIST=SET_" ("_GMN_")"
+12 SET X=LIST
SET DIC(0)="L"
+13 ; SET X GROUP = CHECKLIST
DO ^DIC
IF Y=-1
QUIT
+14 SET DA=+Y
+15 SET TYPE="`"_GIEN
+16 LOCK +^VEN(7.9,DA):0
IF $TEST
DO ^DIE
LOCK -^VEN(7.9,DA)
+17 IF $LENGTH(GSTG)
SET GSTG=GSTG_U
+18 ; THE GSTG CONTAINS THE IENS OF ALL ORDERABLE GROUPS
SET GSTG=GSTG_GIEN
+19 QUIT
End DoDot:1
+20 ; REGISER THE NEW CKLISTS IN THE APPROPRIATE TEMPLATE FILES
IF $LENGTH(GSTG)
DO TEMPLATE(SIEN,GSTG)
+21 QUIT
+22 ;
TEMPLATE(SIEN,GSTG) ; EP-POPULATE THE CHECKLIST SUBFILE IN THE VEN EHP EF TEMPLATES FILE
+1 ; IF THE TEMPLATE CONTAINS THE ORDER SET, ADD ALL THE ORDER GROUPS TO THE CHECKLIST MULTIPLE
+2 NEW DA,DIC,DIE,DR,OSIEN,TIEN,X,PCE
+3 SET TIEN=0
SET SIEN=$GET(SIEN)
+4 ; POPULATE THE TEMPLATE FILE
FOR
SET TIEN=$ORDER(^VEN(7.41,TIEN))
IF 'TIEN
QUIT
Begin DoDot:1
+5 SET OSIEN=$PIECE($GET(^VEN(7.41,TIEN,0)),U,9)
+6 ; MUST BE A MATCH (OR IF BOTH ARE BLANK)
IF OSIEN'=SIEN
QUIT
+7 SET DA(1)=TIEN
SET DIC(0)="L"
SET DLAYGO=19707.4117
+8 SET DIC="^VEN(7.41,"_DA(1)_",17,"
SET DIC("P")="19707.4117P"
+9 FOR PCE=1:1:$LENGTH(GSTG,U)
Begin DoDot:2
+10 SET X=$PIECE(GSTG,U,PCE)
IF 'X
QUIT
+11 SET X="`"_X
+12 ; ADD CHECK LISTS TO THE SUBFILE
DO ^DIC
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 QUIT
+16 ;
ITEMS ; EP-CONVERT ORDERABLES TO CHECKLIST ITEMS
+1 ; GO THRU ALL THE ORDERABLES, CONVERT EACH TO A CHECKLIST ITEM
+2 NEW GIEN,GRP,CKIEN,IGRP,OIEN,%,CAT,MMMN,PMN,ONAME,STG,SIEN,SNAME,CNAME,C1,C2,MN,NAME,PRE,POST
+3 NEW DIC,DIE,DR,DA,X,Y
+4 SET GIEN=0
MNIX ; MAKE INDEX FOR MAIL MERGE/PREFERENCE MNEMONICS
FOR
SET GIEN=$ORDER(^VEN(7.98,GIEN))
IF 'GIEN
QUIT
Begin DoDot:1
+1 ; MAIL MERGE MNEMONIC
SET MMMN=$PIECE($GET(^VEN(7.98,GIEN,0)),U,3)
+2 IF '$LENGTH(MMMN)
QUIT
+3 IF MMMN'="y"
IF MMMN'="h"
+4 IF '$TEST
QUIT
+5 ; PREFERENCE MNEMONIC
SET PMN=$PIECE(^VEN(7.98,GIEN,0),U,2)
+6 IF '$LENGTH(PMN)
QUIT
+7 SET MN(MMMN)=PMN
+8 QUIT
End DoDot:1
COI ; CONVERT ORDERABLES TO ITEMS
+1 SET (DIC,DIE)="^VEN(7.91,"
SET DIC(0)="LX"
SET DLAYGO=19707.91
+2 SET ONAME=""
FOR
SET ONAME=$ORDER(^VEN(7.93,"B",ONAME))
IF ONAME=""
QUIT
SET OIEN=$ORDER(^VEN(7.93,"B",ONAME,0))
IF OIEN
Begin DoDot:1
+3 SET STG=$GET(^VEN(7.93,OIEN,0))
IF '$LENGTH(STG)
QUIT
+4 SET SIEN=+$PIECE(STG,U,2)
IF 'SIEN
SET SNAME="GENERIC CHECK LIST"
+5 IF '$TEST
SET SNAME=$PIECE($GET(^VEN(7.92,SIEN,0)),U)
IF '$LENGTH(SNAME)
QUIT
+6 SET CAT=$PIECE(STG,U,10)
IF CAT=""
QUIT
+7 SET MMMN=$EXTRACT(CAT,2)
IF MMMN=""
QUIT
+8 SET GRP=+CAT
IF GRP
IF GRP=GRP\1
IF GRP>0
IF GRP<5
+9 IF '$TEST
QUIT
+10 SET PMN=$GET(MN(MMMN))
IF PMN=""
QUIT
+11 SET CNAME=SNAME_" ("_PMN_")"
+12 SET CKIEN=$ORDER(^VEN(7.9,"B",CNAME,0))
IF 'CKIEN
QUIT
+13 ; CODES
SET C1=$PIECE(STG,U,6)
SET C2=$PIECE(STG,U,7)
+14 SET PRE=""
SET POST=""
SET NAME=ONAME
+15 ; GET PRE STRING
SET %=$EXTRACT(NAME)
IF %="_"!(%=" ")
Begin DoDot:2
+16 FOR I=1:1:$LENGTH(NAME)
IF $EXTRACT(NAME,I)?1A
QUIT
+17 SET PRE=$EXTRACT(NAME,1,I-1)
SET NAME=$EXTRACT(NNAME,I,999)
+18 QUIT
End DoDot:2
+19 SET %=$EXTRACT(NAME,$LENGTH(NAME))
IF %="_"!(%=" ")
Begin DoDot:2
+20 SET %=$LENGTH(NAME)
+21 FOR I=%:-1:1
IF $EXTRACT(NAME,I)?1A
QUIT
+22 SET POST=$EXTRACT(NAME,I+1,%)
SET NAME=$EXTRACT(NAME,1,I)
+23 QUIT
End DoDot:2
+24 ; STANDARDIZE NAME WITH CAPS
SET X=$$NAME(NAME)
+25 DO ^DIC
IF Y=-1
QUIT
+26 SET DA=+Y
+27 ; POPULATE THE CHECKLIST MULTIPLE
DO CSUB(CKIEN,DA)
+28 ; MAKE DR STRING
SET DR=$$DR(DA,GRP,C1,C2,CKIEN)
IF DR=""
QUIT
+29 LOCK +^VEN(7.91,DA):0
IF $TEST
DO ^DIE
LOCK -^VEN(7.91,DA)
+30 ; UPDATE ITEM WITH THE OTHER ENTRIES OF THE SAME NAME
FOR
SET OIEN=$ORDER(^VEN(7.93,"B",ONAME,OIEN))
IF 'OIEN
QUIT
Begin DoDot:2
+31 SET %=$GET(^VEN(7.93,OIEN,0))
IF '$LENGTH(%)
QUIT
+32 SET CAT=$PIECE(%,U,10)
IF CAT=""
QUIT
+33 SET GRP=+CAT
IF GRP
IF GRP=GRP\1
IF GRP>0
IF GRP<5
+34 IF '$TEST
QUIT
+35 SET C1=$PIECE(%,U,6)
SET C2=$PIECE(%,U,7)
+36 IF PRE=""
SET PRE=$PIECE(%,U,4)
+37 SET PRE=$EXTRACT(PRE,1,9)
SET POST=$EXTRACT(POST,1,9)
+38 SET DR=$$DR(DA,GRP,C1,C2,CKIEN,PRE,POST)
IF DR=""
QUIT
+39 LOCK +^VEN(7.91,DA):0
IF $TEST
DO ^DIE
LOCK -^VEN(7.91,DA)
+40 QUIT
End DoDot:2
+41 QUIT
End DoDot:1
+42 DO ^XBFMK
+43 QUIT
+44 ;
NAME(NAME) ; EP - CAPITALIZE THE 1ST LETTER OF EVERY WORD
+1 NEW L,I,F,X,Y,A
+2 IF '$LENGTH($GET(NAME))
QUIT ""
+3 IF NAME?1.U
QUIT NAME
+4 SET NAME=$$LOW^XLFSTR(NAME)
SET A=""
+5 SET L=$LENGTH(NAME)
SET F=0
SET Y=1
+6 FOR I=1:1:L
SET X=$EXTRACT(NAME,I)
Begin DoDot:1
+7 ; CAP THE IST LETTER
IF Y
IF X?1L
SET Y=0
SET X=$$UP^XLFSTR(X)
SET A=A_X
QUIT
+8 IF X=" "
SET F=1
SET A=A_X
QUIT
+9 ; CAP THE IT LETTER AFTER A SPACE
IF F
IF X?1L
SET F=0
SET X=$$UP^XLFSTR(X)
+10 SET A=A_X
+11 QUIT
End DoDot:1
+12 QUIT A
+13 ;
CSUB(X,Y) ; EP - MAKE ENTRY IN CHECKIN GROUP SUBFILE
+1 NEW DIC,DIE,DA,DR
+2 IF '$DATA(^VEN(7.9,+$GET(X),0))
QUIT
+3 IF '$GET(Y)
QUIT
+4 SET DA(1)=Y
+5 SET DIC="^VEN(7.91,"_DA(1)_",2,"
+6 SET DIC(0)="L"
SET DIC("P")="19707.912P"
SET DLAYGO=19707.912
+7 SET X="`"_X
+8 DO ^DIC
+9 DO ^XBFMK
+10 QUIT
+11 ;
DR(DA,GRP,C1,C2,CKIEN,PRE,POST) ; EP - MAKE DR STG
+1 NEW DR,STG
+2 SET %=$GET(GRP)
IF '%
QUIT
+3 SET DR=".0"_(%+2)_"////1"
+4 SET STG=$GET(^VEN(7.91,+$GET(DA),0))
IF STG=""
QUIT
+5 ; SET PROPERTIES RELATED TO THE CHECKLIST
IF $DATA(^VEN(7.9,+$GET(CKIEN),0))
Begin DoDot:1
+6 IF $PIECE(STG,U,2)=""
SET DR=DR_";.02////"_CKIEN
+7 ; SET PRE FOR THE CHECKLIST - IF NECESSARY
IF $LENGTH($GET(PRE))
IF $PIECE(^VEN(7.9,CKIEN,0),U,3)=""
SET $PIECE(^(0),U,3)=PRE
+8 ; SET POST FOR THE CHECKLIST - IF NECESSARY
IF $LENGTH($GET(POST))
IF $PIECE(^VEN(7.9,CKIEN,0),U,4)=""
SET $PIECE(^(0),U,4)=POST
+9 QUIT
End DoDot:1
+10 IF $LENGTH($GET(C1))
IF $PIECE(STG,U,7)=""
IF C1'[":"
IF C1'[";"
SET DR=DR_";.07////"_C1
+11 IF $LENGTH($GET(C2))
IF $PIECE(STG,U,8)=""
IF C2'[":"
IF C2'[";"
SET DR=DR_";.08////"_C2
+12 QUIT DR
+13 ;
MM(DA) ; EP - COMPUTE MM FIELD VALUE
+1 NEW GIEN,IEN,CNT,MM
+2 SET MM=""
+3 SET GIEN=$PIECE($GET(^VEN(7.91,+$GET(DA),0)),U,2)
IF 'GIEN
QUIT MM
+4 SET MN=$PIECE($GET(^VEN(7.98,GIEN,0)),U,3)
IF '$LENGTH(MN)
QUIT
+5 SET CNT=0
SET IEN=0
+6 FOR
SET IEN=$ORDER(^VEN(7.91,"AC",GIEN,IEN))
IF 'IEN
QUIT
SET CNT=CNT+1
IF IEN=DA
QUIT
+7 IF 'CNT
QUIT MM
+8 SET MM=MN_CNT
+9 QUIT MM
+10 ;
CL(OUT,IN) ; EP - RPC: VEN PCC+ GET CL CATEGORIES
+1 ; RETURN THE ADO TEBLE GEN STRING TO VIEW CHECKLIST CATEGORIES
+2 SET OUT=""
+3 QUIT
+4 ;
CLI(OUT,IN) ; EP - RPC: VNE PCC+ GET CL ITEMS
+1 ; RETURN THE ADO TEBLE GEN STRING TO VIEW CHECKLIST ITEMS
+2 SET OUT=""
+3 IF '$DATA(^VEN(7.9,+$GET(IN),0))
QUIT
+4 SET OUT="BMX ADO SS^VEN CL ITEMS^^AB~"_IN_"~"_IN_"~999999"
+5 QUIT
+6 ;
