VENPCCKB.m

VENPCCKB ; IHS/OIT/GIS - KNOWLEDGEBASE UTILITIES ;

 ;;2.6;PCC+;**1,4**;APR 03, 2012;Build 24

 ;

 ;

 ;

PARSE(PATH,FILE) ; EP - PARSE A KB DEFINITION DOCUMENT AND STORE KB GROUPS AND ITEMS

 N TMP,POP,MN

 I '$L($G(FILE)) Q

 S FILE=$$UP^XLFSTR(FILE)

 S MN=$E($P(FILE,".TXT"),1,4) I '$L(MN) Q

 S TMP=$NA(^TMP("VEN AG",$J)) K @TMP

 S POP=$$OPN^VENPCCP(PATH,FILE,"R","D GET^VENPCCKB") ; CAPTURE TXT FILE AS A GLOBAL ARRAY

 I POP Q

 D PASS1 ; GET KB GROUPS

 D PASS2 ; GET KB ITEMS

 K @TMP,^TMP("VEN AG GROUP",$J)

 Q

 ;

GET ; EP - CAPTURE CONTENT

 N LINE,X,STOP

 S X="",STOP=0

 F LINE=1:1 D  I STOP Q

 . R X:1 E  Q

 . I X["***END***" S STOP=1 Q

 . I X="" Q

 . S @TMP@(LINE)=X

 . Q

 Q

 ;

PASS1 ; EP - GET KB GROUPS

 N LINE,NAME,Y,%,X,DIC,DIE,DR,DA,HDR,CAT

 S X="",LINE=0 K ^TMP("VEN AG GROUP",$J)

 F  S LINE=$O(@TMP@(LINE)) Q:'LINE  D  I X="***END***" Q

 . S X=$G(@TMP@(LINE))

 . I $E(X)=$C(9),$E(X,2)?1A S ^TMP("VEN AG GROUP",$J,$E(X,2,99))=""

 . Q

 S NAME="",%=" and "

 S DIC="^VEN(7.11,",DIC(0)="L",DLAYGO=19707.11,DIE=DIC

 S DR=".03////1;.05////1;.09///^S X=HDR;.1////M"

 F  S NAME=$O(^TMP("VEN AG GROUP",$J,NAME)) Q:NAME=""  D

 . S X=NAME

 . I X[% S X=$P(X,%)_"/"_$P(X,%,2,99)

 . S X=$$UP^XLFSTR(X),HDR="PT ED - "_X,HDR=$E(HDR,1,30),CAT=X

 . S X=MN_" "_X

 . D ^DIC I Y=-1 Q

 . S DA=+Y

 . L +^VEN(7.11,DA):1 I  D ^DIE L -^VEN(7.11,DA)

 . S ^VEN(7.11,DA,2,0)="^^1^1^"_DT_U

 . S ^VEN(7.11,DA,2,1,0)="NATL. ANTICIPETORY GUIDANCE STANDARDS FOR "_CAT

 . S ^TMP("VEN AG GROUP",$J,NAME)=DA

 . Q

 D ^XBFMK

 Q

 ;

PASS2 ; EP - GET KB ITEMS

 N LINE,X,M1,M2,DAY1,DAY2,GROUP,M,W,Y,Z,DIC,DIE,DR,DA,ITEM,TXT,GIEN

 S LINE=0,(DAY1,DAY2)="",GROUP="",GIEN=""

 S (DIC,DIE)="^VEN(7.12,",DIC(0)="L",DLAYGO=19707.12

 S DR=".02///^S X=ITEM;.05///^S X=DAY1;.06///^S X=DAY2;.13///^S X=M1;.14///^S X=M2"

 F  S LINE=$O(@TMP@(LINE)) Q:'LINE  S TXT=@TMP@(LINE) I $L(TXT) D

BRACKET . I TXT["{" D  Q  ; GET THE CURRENT SET OF AGE BRACKETS (IN DAYS AND MONTHS)

 .. S (DAY1,DAY2)="" ; RESET THE AGE RANGE

 .. S Y=$P(TXT,"{",2) S Y=$P(Y,"}")

 .. S M1=+Y,M2=$P(Y,"-",2)

 .. I M1!(M1=0),M2

 .. E  Q

 .. I M1=0 S DAY1=0

 .. E  S DAY1=(30.4375*M1\1)+1

 .. S DAY2=30.4375*M2\1

 .. Q

GRP . I $E(TXT)=$C(9),$E(TXT,2)?1A S GROUP=$E(TXT,2,99),GIEN=$G(^TMP("VEN AG GROUP",$J,GROUP)) Q

ITEM . I (DAY1!(DAY1=0)),DAY2,M2,$L(GROUP),GIEN

 . E  Q  ; AT THIS STAGE DAYS, MONTHS AND GROUP MUST BE DEFINED

 . I $E(TXT,1,2)'=$C(9,9) Q  ; SCREEN OUT ANYTHING THAT IS NOT AN ITEM

 . S ITEM=$E(TXT,3,82) I '$L(ITEM) Q

 . S ITEM=$TR(ITEM,$C(9),"") ; CLEAN OUT ANY TRAILING TABS

 . S X="""`"_GIEN_""""

 . D ^DIC I Y=-1 Q

 . S DA=+Y

 . L +^VEN(7.12,DA):1 I  D ^DIE L -^VEN(7.12,DA)

 . Q

 D ^XBFMK

 Q

 ; 

PEC ; EP - AUTOMATICALLY ASSIGN PATIENT ED CODES TO ITEMS

 N IIEN,ITEM,X,Y,Z,CIEN,PRE,CODE,GRP

 S IIEN=0

 F  S IIEN=$O(^VEN(7.12,IIEN)) Q:'IIEN  D  ; CHECK EACH ITEM

 . S X=$G(^VEN(7.12,IIEN,0)) I '$L(X) Q

 . S CIEN=+X S Y=$G(^VEN(7.11,CIEN,0)) I '$L(Y) Q

 . S PRE=$P(Y,U,12) I '$L(PRE) Q

 . S CODE=$P(Y,U,13) I '$L(CODE) Q

 . S Z=$P(X,U,6),GRP=$S(Z<62:"N",Z<366:"I",Z<1096:"T",Z<1827:"P",Z<4384:"S",Z<7686:"A",1:"")

 . S $P(X,U,4)=PRE_GRP_"-"_CODE,^VEN(7.12,IIEN,0)=X

 . Q

 Q

 ; 

TOPIC ; EP - IF ENTRIES ARE MISSING FROM THE EDUCATION TOPIC FILE, ADD THEM NOW

 N TIEN,STOPIC,MN,X,Y,Z,%,TMP,CNT,FULL,STG,NAME,MAJ,EIEN,TNAME,KGBL

 S TMP=$NA(^TMP("VEN EDU",$J)) K @TMP

 I '$G(KIEN) S KIEN=0

TARR ; MAKE TEMP ARRAY OF ALL MNEMONICS AND THEIR SUB-TOPICS IN THE KB ITEM FILE

 S KGBL=$NA(^VEN(7.12))

 F  S KIEN=$O(@KGBL@(KIEN)) Q:'KIEN  D

 . S MN=$P($G(@KGBL@(KIEN,2)),U,3) I MN="" Q  ; TOPIC MNEMONIC

 . S MAJ=$P(MN,"-") I MAJ="" Q  ; MAJOR TOPIC.  BY DEFAULT, ALL WCM MAJOR TOPICS WILL BE THE 1ST PIECE OF THE MN

 . S TNAME=$P(@KGBL@(KIEN,2),U,6) I TNAME="" S TNAME=MN,$P(@KGBL@(KIEN,2),U,6)=MN ; FULL TOPIC NAME

 . S EIEN=$O(^AUTTEDT("C",MN,99999999),-1) ; GIVEN A MN FROM THE KB ITEM FILE, FIND THE IEN OF THE NEWEST TOPIC TOPIC IN EDU TOPIC FILE WITH THAT EXACT MN

 . I EIEN D  Q  ; THE MNEMONIC IS ALREADY IN THERE.  CLEAN IT UP AND QUIT 

 .. S %=$NA(^AUTTEDT(EIEN))

 .. S $P(@%@(0),U,3)="",$P(@%@(0),U,5)="" ; MAKE SURE IT'S ACTIIVE

 .. S $P(@%@(0),U,6)=MAJ ; MAKE SUR MAJOR TOPIC IS SYNC'D

 .. Q

 . S Y=$P(MN,"-",2,99) ; FIRST VALIDATE THE MNEMONIC STORED IN THE KB ITEM FILE

 . I '$L(Y) Q

 . I $L(Y)>3 Q

 . I Y?.E1.N.E Q

 . S @TMP@(MN)=TNAME ; FULL TOPIC NAME

 . S STOPIC=$P(^VEN(7.12,KIEN,0),U,2) I '$L(STOPIC) Q  ; SUB-TOPIC NAME

 . S %=$O(@TMP@(MN,999999),-1)+1

 . S @TMP@(MN,%)=STOPIC ; SUB TOPIC ARRAY

 . Q

TENT ; FOR EACH ITEM IN THE ARRAY, MAKE NEW ENTRY IN THE EDUCATION TOPIC FILE - IF NECESSARY

 S MN=""

 F  S MN=$O(@TMP@(MN)) Q:'$L(MN)  D  ; LOOP THROUGH THE MENOMIC ARRAY OF UN-ENTERED TOPICS

 . S TNAME=@TMP@(MN)

 . S MAJ=$P(MN,"-")

 . S STG="",CNT=0

 . F  S CNT=$O(@TMP@(MN,CNT)) Q:'CNT  D  ; FOR EA TOPIC, BUILD A LONG TEXT STRING WITH ALL SUBTOPICS IN IT

 .. S X=@TMP@(MN,CNT) I '$L(X) Q

 .. S X=CNT_". "_X

 .. I $L(STG) S STG=STG_".  "

 .. S STG=STG_X

 .. Q

WPARR .; CONVERT THE SUBTOPIC STG TO AN ARRAY THAT CAN BE GRAFTED INTO THE WP (SUBTOPIC) FIELD OT EDU TOPIC FILE

 . K ARR S CNT=0

 . F  D  I '$L(STG) Q

 ..  S CNT=CNT+1

 ..  I $L(STG)<61 S ARR(CNT)=STG,STG="" Q

 ..  S X=$E(STG,1,60),Y=$E(STG,61,9999),Z=$P(Y," ")

 ..  S ARR(CNT)=X_Z_" ",%=$L(ARR(CNT))+1

 ..  S STG=$E(STG,%,9999)

 ..  Q

 . D TDIC(MN,MAJ,TNAME,.ARR) ; FILL OUT THE NEW TOPIC ENTRY

 . Q

 K @TMP

 Q

 ; 

TDIC(MN,MAJ,TNAME,ARR) ; EP - MAKE NEW EDUCATION TOPIC ENTRY

 N DIC,DIE,DA,DR,X,Y,%,CNT,GBL

 S DIC="^AUTTEDT(",DIC(0)="L",DLAYGO=9999999.09

 S X=TNAME

 D ^DIC I Y=-1 Q

 S DIE=DIC,DA=+Y,DR=".06///^S X=MAJ;1///^S X=MN"

 S GBL=$NA(^AUTTEDT(DA))

 L +@GBL:1 I  D ^DIE L -@GBL

 S CNT=$O(ARR(9999),-1)

 S @GBL@(2,0)="^^"_CNT_U_CNT_U_DT ; STUFF STANDARDS FIELD WITH WP ARRAY - BASED ON SUBTOPICS IN KB ITEM FILE

 F X=1:1:CNT S @GBL@(2,X,0)=ARR(X)

 D ^XBFMK K ARR

 W !?10,TNAME," (",MN,")  <-Added"

 Q

 ; 

CONVERT ; EP - CONVERT ENTRIES TO NEW NATL STDS

 N X,DIC,Y,%,CAT,IIEN,STG,Z

 S IIEN=0,DIC="^VEN(7.12,",DLAYGO=19707.12,DIC(0)="L"

 F  S IIEN=$O(^VEN(7.12,IIEN)) Q:'IIEN  D  I IIEN>1964 Q

 . S STG=$G(^VEN(7.12,IIEN,0)),%=+STG

 . S X=$S(%=1:34,%=3:35,%=4:36,%=5:37,1:0) I 'X Q

 . S $P(STG,U,1)=X

 . S X="""`"_X_""""

 . D ^DIC I Y=-1 Q

 . S ^VEN(7.12,+Y,0)=STG

 . Q

 D ^XBFMK

 Q

 ; 

PTED ; EP - PATIENT ED CODES

 N DA

 S DA=0

 F  S DA=$O(^VEN(7.12,DA)) Q:'DA  D

 . S X=$P($G(^VEN(7.12,DA,0)),U,4)

 . I $E(X,1,2)'="CH" Q

 . I X?.E1.N.E Q  ; MUST BE A NATL CODE

 . S $P(^VEN(7.12,DA,2),U,3)=X

 . Q

 Q

 ; 

CHA ; EP - CONVERT CH TO CHA

 N KIEN,X,Y,%

 S KIEN=0

 F  S KIEN=$O(^VEN(7.12,KIEN)) Q:'KIEN  S X=$P($G(^VEN(7.12,KIEN,0)),U,4) I $E(X,1,3)="CH-" D

 . S X="CHA-"_$P(X,"-",2)

 . S $P(^VEN(7.12,KIEN,0),U,4)=X

 . Q

 Q

 ; 

NAME(MN) ; EP - TRIGGER: GIVEN A ED TOPIC MNEMONIC, RETURN THE NAME FROM THE PT ED FILE

 I '$L($G(MN)) Q

 N EIEN,NAME,X,Y,Z

 S EIEN=0,NAME=""

 F  S EIEN=$O(^AUTTEDT("C",MN,EIEN)) Q:'EIEN  D  I NAME Q

 . I $P($G(^AUTTEDT(EIEN,0)),U,3) Q  ; INACTIVE

 . S NAME=$P($G(^AUTTEDT(EIEN,0)),U)

 . Q

 ; I NAME="" W !,MN

 Q NAME

 ;  

VENPCCKB  ; IHS/OIT/GIS - KNOWLEDGEBASE UTILITIES ;

 +1       ;;2.6;PCC+;**1,4**;APR 03, 2012;Build 24

 +2       ;

 +3       ;

 +4       ;

PARSE(PATH,FILE) ; EP - PARSE A KB DEFINITION DOCUMENT AND STORE KB GROUPS AND ITEMS

 +1        NEW TMP,POP,MN

 +2        IF '$LENGTH($GET(FILE))

               QUIT 

 +3        SET FILE=$$UP^XLFSTR(FILE)

 +4        SET MN=$EXTRACT($PIECE(FILE,".TXT"),1,4)

           IF '$LENGTH(MN)

               QUIT 

 +5        SET TMP=$NAME(^TMP("VEN AG",$JOB))

           KILL @TMP

 +6       ; CAPTURE TXT FILE AS A GLOBAL ARRAY

           SET POP=$$OPN^VENPCCP(PATH,FILE,"R","D GET^VENPCCKB")

 +7        IF POP

               QUIT 

 +8       ; GET KB GROUPS

           DO PASS1

 +9       ; GET KB ITEMS

           DO PASS2

 +10       KILL @TMP,^TMP("VEN AG GROUP",$JOB)

 +11       QUIT 

 +12      ;

GET       ; EP - CAPTURE CONTENT

 +1        NEW LINE,X,STOP

 +2        SET X=""

           SET STOP=0

 +3        FOR LINE=1:1

               Begin DoDot:1

 +4                READ X:1

                  IF '$TEST

                       QUIT 

 +5                IF X["***END***"

                       SET STOP=1

                       QUIT 

 +6                IF X=""

                       QUIT 

 +7                SET @TMP@(LINE)=X

 +8                QUIT 

               End DoDot:1

               IF STOP

                   QUIT 

 +9        QUIT 

 +10      ;

PASS1     ; EP - GET KB GROUPS

 +1        NEW LINE,NAME,Y,%,X,DIC,DIE,DR,DA,HDR,CAT

 +2        SET X=""

           SET LINE=0

           KILL ^TMP("VEN AG GROUP",$JOB)

 +3        FOR 

               SET LINE=$ORDER(@TMP@(LINE))

               IF 'LINE

                   QUIT 

               Begin DoDot:1

 +4                SET X=$GET(@TMP@(LINE))

 +5                IF $EXTRACT(X)=$CHAR(9)

                       IF $EXTRACT(X,2)?1A

                           SET ^TMP("VEN AG GROUP",$JOB,$EXTRACT(X,2,99))=""

 +6                QUIT 

               End DoDot:1

               IF X="***END***"

                   QUIT 

 +7        SET NAME=""

           SET %=" and "

 +8        SET DIC="^VEN(7.11,"

           SET DIC(0)="L"

           SET DLAYGO=19707.11

           SET DIE=DIC

 +9        SET DR=".03////1;.05////1;.09///^S X=HDR;.1////M"

 +10       FOR 

               SET NAME=$ORDER(^TMP("VEN AG GROUP",$JOB,NAME))

               IF NAME=""

                   QUIT 

               Begin DoDot:1

 +11               SET X=NAME

 +12               IF X[%

                       SET X=$PIECE(X,%)_"/"_$PIECE(X,%,2,99)

 +13               SET X=$$UP^XLFSTR(X)

                   SET HDR="PT ED - "_X

                   SET HDR=$EXTRACT(HDR,1,30)

                   SET CAT=X

 +14               SET X=MN_" "_X

 +15               DO ^DIC

                   IF Y=-1

                       QUIT 

 +16               SET DA=+Y

 +17               LOCK +^VEN(7.11,DA):1

                  IF $TEST

                       DO ^DIE

                       LOCK -^VEN(7.11,DA)

 +18               SET ^VEN(7.11,DA,2,0)="^^1^1^"_DT_U

 +19               SET ^VEN(7.11,DA,2,1,0)="NATL. ANTICIPETORY GUIDANCE STANDARDS FOR "_CAT

 +20               SET ^TMP("VEN AG GROUP",$JOB,NAME)=DA

 +21               QUIT 

               End DoDot:1

 +22       DO ^XBFMK

 +23       QUIT 

 +24      ;

PASS2     ; EP - GET KB ITEMS

 +1        NEW LINE,X,M1,M2,DAY1,DAY2,GROUP,M,W,Y,Z,DIC,DIE,DR,DA,ITEM,TXT,GIEN

 +2        SET LINE=0

           SET (DAY1,DAY2)=""

           SET GROUP=""

           SET GIEN=""

 +3        SET (DIC,DIE)="^VEN(7.12,"

           SET DIC(0)="L"

           SET DLAYGO=19707.12

 +4        SET DR=".02///^S X=ITEM;.05///^S X=DAY1;.06///^S X=DAY2;.13///^S X=M1;.14///^S X=M2"

 +5        FOR 

               SET LINE=$ORDER(@TMP@(LINE))

               IF 'LINE

                   QUIT 

               SET TXT=@TMP@(LINE)

               IF $LENGTH(TXT)

                   Begin DoDot:1

BRACKET   ; GET THE CURRENT SET OF AGE BRACKETS (IN DAYS AND MONTHS)

                       IF TXT["{"

                           Begin DoDot:2

 +1       ; RESET THE AGE RANGE

                               SET (DAY1,DAY2)=""

 +2                            SET Y=$PIECE(TXT,"{",2)

                               SET Y=$PIECE(Y,"}")

 +3                            SET M1=+Y

                               SET M2=$PIECE(Y,"-",2)

 +4                            IF M1!(M1=0)

                                   IF M2

 +5                           IF '$TEST

                                   QUIT 

 +6                            IF M1=0

                                   SET DAY1=0

 +7                           IF '$TEST

                                   SET DAY1=(30.4375*M1\1)+1

 +8                            SET DAY2=30.4375*M2\1

 +9                            QUIT 

                           End DoDot:2

                           QUIT 

GRP                    IF $EXTRACT(TXT)=$CHAR(9)

                           IF $EXTRACT(TXT,2)?1A

                               SET GROUP=$EXTRACT(TXT,2,99)

                               SET GIEN=$GET(^TMP("VEN AG GROUP",$JOB,GROUP))

                               QUIT 

ITEM                   IF (DAY1!(DAY1=0))

                           IF DAY2

                               IF M2

                                   IF $LENGTH(GROUP)

                                       IF GIEN

 +1       ; AT THIS STAGE DAYS, MONTHS AND GROUP MUST BE DEFINED

                      IF '$TEST

                           QUIT 

 +2       ; SCREEN OUT ANYTHING THAT IS NOT AN ITEM

                       IF $EXTRACT(TXT,1,2)'=$CHAR(9,9)

                           QUIT 

 +3                    SET ITEM=$EXTRACT(TXT,3,82)

                       IF '$LENGTH(ITEM)

                           QUIT 

 +4       ; CLEAN OUT ANY TRAILING TABS

                       SET ITEM=$TRANSLATE(ITEM,$CHAR(9),"")

 +5                    SET X="""`"_GIEN_""""

 +6                    DO ^DIC

                       IF Y=-1

                           QUIT 

 +7                    SET DA=+Y

 +8                    LOCK +^VEN(7.12,DA):1

                      IF $TEST

                           DO ^DIE

                           LOCK -^VEN(7.12,DA)

 +9                    QUIT 

                   End DoDot:1

 +10       DO ^XBFMK

 +11       QUIT 

 +12      ; 

PEC       ; EP - AUTOMATICALLY ASSIGN PATIENT ED CODES TO ITEMS

 +1        NEW IIEN,ITEM,X,Y,Z,CIEN,PRE,CODE,GRP

 +2        SET IIEN=0

 +3       ; CHECK EACH ITEM

           FOR 

               SET IIEN=$ORDER(^VEN(7.12,IIEN))

               IF 'IIEN

                   QUIT 

               Begin DoDot:1

 +4                SET X=$GET(^VEN(7.12,IIEN,0))

                   IF '$LENGTH(X)

                       QUIT 

 +5                SET CIEN=+X

                   SET Y=$GET(^VEN(7.11,CIEN,0))

                   IF '$LENGTH(Y)

                       QUIT 

 +6                SET PRE=$PIECE(Y,U,12)

                   IF '$LENGTH(PRE)

                       QUIT 

 +7                SET CODE=$PIECE(Y,U,13)

                   IF '$LENGTH(CODE)

                       QUIT 

 +8                SET Z=$PIECE(X,U,6)

                   SET GRP=$SELECT(Z<62:"N",Z<366:"I",Z<1096:"T",Z<1827:"P",Z<4384:"S",Z<7686:"A",1:"")

 +9                SET $PIECE(X,U,4)=PRE_GRP_"-"_CODE

                   SET ^VEN(7.12,IIEN,0)=X

 +10               QUIT 

               End DoDot:1

 +11       QUIT 

 +12      ; 

TOPIC     ; EP - IF ENTRIES ARE MISSING FROM THE EDUCATION TOPIC FILE, ADD THEM NOW

 +1        NEW TIEN,STOPIC,MN,X,Y,Z,%,TMP,CNT,FULL,STG,NAME,MAJ,EIEN,TNAME,KGBL

 +2        SET TMP=$NAME(^TMP("VEN EDU",$JOB))

           KILL @TMP

 +3        IF '$GET(KIEN)

               SET KIEN=0

TARR      ; MAKE TEMP ARRAY OF ALL MNEMONICS AND THEIR SUB-TOPICS IN THE KB ITEM FILE

 +1        SET KGBL=$NAME(^VEN(7.12))

 +2        FOR 

               SET KIEN=$ORDER(@KGBL@(KIEN))

               IF 'KIEN

                   QUIT 

               Begin DoDot:1

 +3       ; TOPIC MNEMONIC

                   SET MN=$PIECE($GET(@KGBL@(KIEN,2)),U,3)

                   IF MN=""

                       QUIT 

 +4       ; MAJOR TOPIC.  BY DEFAULT, ALL WCM MAJOR TOPICS WILL BE THE 1ST PIECE OF THE MN

                   SET MAJ=$PIECE(MN,"-")

                   IF MAJ=""

                       QUIT 

 +5       ; FULL TOPIC NAME

                   SET TNAME=$PIECE(@KGBL@(KIEN,2),U,6)

                   IF TNAME=""

                       SET TNAME=MN

                       SET $PIECE(@KGBL@(KIEN,2),U,6)=MN

 +6       ; GIVEN A MN FROM THE KB ITEM FILE, FIND THE IEN OF THE NEWEST TOPIC TOPIC IN EDU TOPIC FILE WITH THAT EXACT MN

                   SET EIEN=$ORDER(^AUTTEDT("C",MN,99999999),-1)

 +7       ; THE MNEMONIC IS ALREADY IN THERE.  CLEAN IT UP AND QUIT 

                   IF EIEN

                       Begin DoDot:2

 +8                        SET %=$NAME(^AUTTEDT(EIEN))

 +9       ; MAKE SURE IT'S ACTIIVE

                           SET $PIECE(@%@(0),U,3)=""

                           SET $PIECE(@%@(0),U,5)=""

 +10      ; MAKE SUR MAJOR TOPIC IS SYNC'D

                           SET $PIECE(@%@(0),U,6)=MAJ

 +11                       QUIT 

                       End DoDot:2

                       QUIT 

 +12      ; FIRST VALIDATE THE MNEMONIC STORED IN THE KB ITEM FILE

                   SET Y=$PIECE(MN,"-",2,99)

 +13               IF '$LENGTH(Y)

                       QUIT 

 +14               IF $LENGTH(Y)>3

                       QUIT 

 +15               IF Y?.E1.N.E

                       QUIT 

 +16      ; FULL TOPIC NAME

                   SET @TMP@(MN)=TNAME

 +17      ; SUB-TOPIC NAME

                   SET STOPIC=$PIECE(^VEN(7.12,KIEN,0),U,2)

                   IF '$LENGTH(STOPIC)

                       QUIT 

 +18               SET %=$ORDER(@TMP@(MN,999999),-1)+1

 +19      ; SUB TOPIC ARRAY

                   SET @TMP@(MN,%)=STOPIC

 +20               QUIT 

               End DoDot:1

TENT      ; FOR EACH ITEM IN THE ARRAY, MAKE NEW ENTRY IN THE EDUCATION TOPIC FILE - IF NECESSARY

 +1        SET MN=""

 +2       ; LOOP THROUGH THE MENOMIC ARRAY OF UN-ENTERED TOPICS

           FOR 

               SET MN=$ORDER(@TMP@(MN))

               IF '$LENGTH(MN)

                   QUIT 

               Begin DoDot:1

 +3                SET TNAME=@TMP@(MN)

 +4                SET MAJ=$PIECE(MN,"-")

 +5                SET STG=""

                   SET CNT=0

 +6       ; FOR EA TOPIC, BUILD A LONG TEXT STRING WITH ALL SUBTOPICS IN IT

                   FOR 

                       SET CNT=$ORDER(@TMP@(MN,CNT))

                       IF 'CNT

                           QUIT 

                       Begin DoDot:2

 +7                        SET X=@TMP@(MN,CNT)

                           IF '$LENGTH(X)

                               QUIT 

 +8                        SET X=CNT_". "_X

 +9                        IF $LENGTH(STG)

                               SET STG=STG_".  "

 +10                       SET STG=STG_X

 +11                       QUIT 

                       End DoDot:2

WPARR     ; CONVERT THE SUBTOPIC STG TO AN ARRAY THAT CAN BE GRAFTED INTO THE WP (SUBTOPIC) FIELD OT EDU TOPIC FILE

 +1                KILL ARR

                   SET CNT=0

 +2                FOR 

                       Begin DoDot:2

 +3                        SET CNT=CNT+1

 +4                        IF $LENGTH(STG)<61

                               SET ARR(CNT)=STG

                               SET STG=""

                               QUIT 

 +5                        SET X=$EXTRACT(STG,1,60)

                           SET Y=$EXTRACT(STG,61,9999)

                           SET Z=$PIECE(Y," ")

 +6                        SET ARR(CNT)=X_Z_" "

                           SET %=$LENGTH(ARR(CNT))+1

 +7                        SET STG=$EXTRACT(STG,%,9999)

 +8                        QUIT 

                       End DoDot:2

                       IF '$LENGTH(STG)

                           QUIT 

 +9       ; FILL OUT THE NEW TOPIC ENTRY

                   DO TDIC(MN,MAJ,TNAME,.ARR)

 +10               QUIT 

               End DoDot:1

 +11       KILL @TMP

 +12       QUIT 

 +13      ; 

TDIC(MN,MAJ,TNAME,ARR) ; EP - MAKE NEW EDUCATION TOPIC ENTRY

 +1        NEW DIC,DIE,DA,DR,X,Y,%,CNT,GBL

 +2        SET DIC="^AUTTEDT("

           SET DIC(0)="L"

           SET DLAYGO=9999999.09

 +3        SET X=TNAME

 +4        DO ^DIC

           IF Y=-1

               QUIT 

 +5        SET DIE=DIC

           SET DA=+Y

           SET DR=".06///^S X=MAJ;1///^S X=MN"

 +6        SET GBL=$NAME(^AUTTEDT(DA))

 +7        LOCK +@GBL:1

          IF $TEST

               DO ^DIE

               LOCK -@GBL

 +8        SET CNT=$ORDER(ARR(9999),-1)

 +9       ; STUFF STANDARDS FIELD WITH WP ARRAY - BASED ON SUBTOPICS IN KB ITEM FILE

           SET @GBL@(2,0)="^^"_CNT_U_CNT_U_DT

 +10       FOR X=1:1:CNT

               SET @GBL@(2,X,0)=ARR(X)

 +11       DO ^XBFMK

           KILL ARR

 +12       WRITE !?10,TNAME," (",MN,")  <-Added"

 +13       QUIT 

 +14      ; 

CONVERT   ; EP - CONVERT ENTRIES TO NEW NATL STDS

 +1        NEW X,DIC,Y,%,CAT,IIEN,STG,Z

 +2        SET IIEN=0

           SET DIC="^VEN(7.12,"

           SET DLAYGO=19707.12

           SET DIC(0)="L"

 +3        FOR 

               SET IIEN=$ORDER(^VEN(7.12,IIEN))

               IF 'IIEN

                   QUIT 

               Begin DoDot:1

 +4                SET STG=$GET(^VEN(7.12,IIEN,0))

                   SET %=+STG

 +5                SET X=$SELECT(%=1:34,%=3:35,%=4:36,%=5:37,1:0)

                   IF 'X

                       QUIT 

 +6                SET $PIECE(STG,U,1)=X

 +7                SET X="""`"_X_""""

 +8                DO ^DIC

                   IF Y=-1

                       QUIT 

 +9                SET ^VEN(7.12,+Y,0)=STG

 +10               QUIT 

               End DoDot:1

               IF IIEN>1964

                   QUIT 

 +11       DO ^XBFMK

 +12       QUIT 

 +13      ; 

PTED      ; EP - PATIENT ED CODES

 +1        NEW DA

 +2        SET DA=0

 +3        FOR 

               SET DA=$ORDER(^VEN(7.12,DA))

               IF 'DA

                   QUIT 

               Begin DoDot:1

 +4                SET X=$PIECE($GET(^VEN(7.12,DA,0)),U,4)

 +5                IF $EXTRACT(X,1,2)'="CH"

                       QUIT 

 +6       ; MUST BE A NATL CODE

                   IF X?.E1.N.E

                       QUIT 

 +7                SET $PIECE(^VEN(7.12,DA,2),U,3)=X

 +8                QUIT 

               End DoDot:1

 +9        QUIT 

 +10      ; 

CHA       ; EP - CONVERT CH TO CHA

 +1        NEW KIEN,X,Y,%

 +2        SET KIEN=0

 +3        FOR 

               SET KIEN=$ORDER(^VEN(7.12,KIEN))

               IF 'KIEN

                   QUIT 

               SET X=$PIECE($GET(^VEN(7.12,KIEN,0)),U,4)

               IF $EXTRACT(X,1,3)="CH-"

                   Begin DoDot:1

 +4                    SET X="CHA-"_$PIECE(X,"-",2)

 +5                    SET $PIECE(^VEN(7.12,KIEN,0),U,4)=X

 +6                    QUIT 

                   End DoDot:1

 +7        QUIT 

 +8       ; 

NAME(MN)  ; EP - TRIGGER: GIVEN A ED TOPIC MNEMONIC, RETURN THE NAME FROM THE PT ED FILE

 +1        IF '$LENGTH($GET(MN))

               QUIT 

 +2        NEW EIEN,NAME,X,Y,Z

 +3        SET EIEN=0

           SET NAME=""

 +4        FOR 

               SET EIEN=$ORDER(^AUTTEDT("C",MN,EIEN))

               IF 'EIEN

                   QUIT 

               Begin DoDot:1

 +5       ; INACTIVE

                   IF $PIECE($GET(^AUTTEDT(EIEN,0)),U,3)

                       QUIT 

 +6                SET NAME=$PIECE($GET(^AUTTEDT(EIEN,0)),U)

 +7                QUIT 

               End DoDot:1

               IF NAME

                   QUIT 

 +8       ; I NAME="" W !,MN

 +9        QUIT NAME

 +10      ;