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 ;
