Routine: VENPCCC

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

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

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

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

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

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

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=""

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"

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       ;

VENPCCC.m