VENPCCK ; IHS/OIT/GIS - KNOWLEDGE BASE ;
;;2.6;PCC+;**1,3**;APR 03, 2012;Build 24
;
;
;
;
FETCH(DEFEF,DFN) ; EP-RETURN KNOWLEDGEBASE DATA
I '$D(^DPT(+$G(DFN),0)) Q
N KCIEN,IFLG,KIEN,HDR,IEN,STG,K,AGE,SEX,AGEFLAG,SEXFLAG,LAGFLAG,GESTFLAG,START,STOP,TMP,IX
N CNT,TITLE,MOD,TOT,ARR,CAT,TIEN,DOM,ORD,KC,DORD,DIEN,%,LASTCNT,PECODE,AGEGRP
S TMP=$NA(^TMP("VEN PRNT",$J,1))
; THERE ARE 2 POSSIBLE DRIVERS TO COLLECT KB ITEMS: LEGACY AND NEW. THE DEFAULT DRIVER IS THE NEW ONE.
I '$O(^VEN(7.41,DEFEF,19,0)) G LEGACY ; IF THE DOMAIN MULTIPLE DOES NOT EXIST, USE THE LEGACY DRIVER
NEW S DIEN=0 ; NEW GUIDELINES DRIVER
F S DIEN=$O(^VEN(7.41,DEFEF,19,DIEN)) Q:'DIEN D ; DOMAIN CONTEXT DRIVER (PREFERRED IF IT EXISTS)
. S %=$G(^VEN(7.41,DEFEF,19,DIEN,0))
. S DOM=+% I 'DOM Q
. I '$P($G(^VEN(7.13,DOM,0)),U,7) Q ; DOMAIN MUST BE ACTIVE
. I $P($G(^VEN(7.13,DOM,0)),U)["NATL AG" Q ; NEW DRIVER EXCLUDES PT ED GUIDELINES. THESE ARE HANDLED SEPARATELY
. S DORD=$P(%,U,2) I 'DORD S DORD=DIEN+100 ; EVERY DOMAIN MUST HAVE AN ORDER OR ONE WILL BE ASSIGNED
. S KC=0
. F S KC=$O(^VEN(7.13,DOM,1,KC)) Q:'KC D ; CREATE THE ORDINAL ARRAY.
.. S %=$G(^VEN(7.13,DOM,1,KC,0))
.. S KCIEN=+% I 'KCIEN Q
.. S ORD=$P(%,U,2)
.. I 'ORD S ORD=100+KC ; MAKE SURE EVERY CAT HAS AN ORDER - EVEN IF ONE IS NOT OFFICIALLY ASSIGNED
.. S ORD(DORD,ORD)=KCIEN
.. Q
. Q
S DORD=0,CNT=0
SET F S DORD=$O(ORD(DORD)) Q:'DORD D
. S ORD=0 F S ORD=$O(ORD(DORD,ORD)) Q:'ORD D I CNT>99 Q
.. S KCIEN=ORD(DORD,ORD)
.. I 'KCIEN Q
.. S LASTCNT=CNT
.. D GETKBI(KCIEN,.CNT) ; TRAVERSE THE ARRAY TO RETRIEVE CATS
.. Q
. I LASTCNT'=CNT S CNT=CNT+1 S @TMP@("k"_CNT)="." ; PUT A SPACER LINE BETWEEN DOMAINS
. Q
Q
;
LEGACY ; EP-IF THE DOMAIN CONTEXT IS NOT DEFINED, USE THE LEGACY DRIVER BEASED ON THE KB MULTIPLE IN THE TEMPLATE FILE
; FOR BACKWARD COMPATIBILITY ONLY. THIS WILL BE PHASED OUT
I '$O(^VEN(7.41,+$G(DEFEF),16,0)) Q ; IF THERE ARE NO KB ITEMS ASOCIATED WITH THE CURRENT FORM QUIT
N CNT,TIEN,KCIEN,CNT
S TIEN=0,CNT=0
F S TIEN=$O(^VEN(7.41,DEFEF,16,TIEN)) Q:'TIEN D I CNT>99 Q ; LEGACY DRIVER FROM VER 2.5
. S KCIEN=$G(^VEN(7.41,+$G(DEFEF),16,TIEN,0))
. I 'KCIEN Q
. D GETKBI(KCIEN,.CNT) ; GET INFO ABOUT KNOWLEDGE CATEGORY
. Q
Q
;
GETKBI(KCIEN,CNT) ; EP - GET KB ITEMS FROM A SPECIFIC CATEGORY
N AGE
S K=$G(^VEN(7.11,KCIEN,0)) I '$L(K) Q
S CAT=$P(K,U) I '$L(CAT) Q
S HDR=$P(K,U,9)
S CNT=CNT+1 I CNT>100 Q
S AGEFLAG=$P(K,U,5) ; SCREEN BY AGE
I AGEFLAG S AGE=$$DAYS(DFN) I 'AGE Q
S GESTFLAG=$P(K,U,6) ; SCREEN BY WKS GESTATION
S LAGFLAG=$P(K,U,7) ; SCREEN BY TIME SINCE LAST
S SEXFLAG=$P(K,U,8) ; SCREEN BY SEX
I SEXFLAG S SEX=$P($G(^DPT(+$G(DFN),0)),U,2) I '$L(SEX) Q
I $G(AGE) S PECODE=$P(K,U,13) I $L(PECODE) D
. S Z=AGE,AGEGRP=$S(Z<62:"N",Z<366:"I",Z<1096:"T",Z<1827:"P",Z<4384:"S",Z<7686:"A",1:"")
. I '$L(AGEGRP) Q
. S HDR=HDR_" ("_PECODE_"-"_AGEGRP_")"
. Q
S @TMP@("k"_CNT)=HDR ; SET THE HEADER NODE FOR THIS SET OF ITEMS
S KIEN=0,TOT=0 K ARR
F S KIEN=$O(^VEN(7.12,"B",KCIEN,KIEN)) Q:'KIEN D I CNT>99 Q ; CHECK EA. ENTRY IN THE KNOWLEDGE CATEGORY
. S STG=$G(^VEN(7.12,KIEN,0)) I '$L(STG) Q
. I $P(STG,U,11) Q ; INACTIVE ITEM !!!
. I AGEFLAG S START=$P(STG,U,5) I AGE<START Q
. I AGEFLAG S STOP=$P(STG,U,6) I AGE>STOP Q
. I SEXFLAG S %=$P(STG,U,10) I $L(%),%'=SEX Q
. S TITLE=$P(STG,U,2) I '$L(TITLE) Q
. I CAT["WCAG "!(CAT["WCEX ") D LAST(KCIEN,KIEN,DFN,.TITLE) ; FOR PT ED, APPEND LAST PT ED RESULTS TO TITLE
. S MOD=$P(STG,U,12)
. I $L(MOD) S TITLE=TITLE_" ("_MOD_")"
. I MOD,($P($G(^VEN(7.12,KIEN,0)),U,16)!(CAT["WELL CHILD DEVEL")!(CAT["WCDA ")) D Q
.. S TOT=TOT+1
.. S ARR(MOD,TOT)="__ "_TITLE
.. S ARR(MOD,TOT,"IX")=KIEN
.. Q
. ; NO SECONDARY SORT REQUIRED
. S CNT=CNT+1,TOT=TOT+1
. S @TMP@("k"_CNT)="__ "_TITLE ; SET THE ITEM NODE
. S @TMP@("k"_CNT,"IX")=KIEN ; ITEM IEN X-REF
. Q
NOITEMS I 'TOT K @TMP@("k"_CNT) S CNT=CNT-1 Q ; NO ITEMS FOUND IN THIS CATEGORY, SO DELETE IT
I $D(ARR) D ; SORT BY %ILE
. S MOD=999
. F S MOD=$O(ARR(MOD),-1) Q:'MOD S TOT=0 F S TOT=$O(ARR(MOD,TOT)) Q:'TOT D I CNT>99 Q
.. S CNT=CNT+1
.. S @TMP@("k"_CNT)=ARR(MOD,TOT)
.. S @TMP@("k"_CNT,"IX")=ARR(MOD,TOT,"IX")
.. Q
. K ARR
. Q
KX Q
;
LAST(KCIEN,KIEN,DFN,TITLE) ; EP - GET LAST RESULT AND APPEND TO RESULT
N MAXIDT,LASTDT,LASTRES,TXT,%
S MAXIDT=9999999-(DT-20000) ; GO BACK UP TO 2 YEARS
S TXT=TITLE
I $E(TXT,1,3)="__ " S TXT=$E(TXT,4,999)
D LAST^VENPCCKX(KIEN,KCIEN,TXT,DFN,MAXIDT,.LASTDT,.LASTRES)
I '$G(LASTDT) Q
S %=$$FMTE^XLFDT(LASTDT,2) I '$L(%) Q
I $L($G(LASTRES)) S %=%_" "_LASTRES
S TITLE=TITLE_" ("_%_")"
Q
;
IMPORT ; EP-IMPORT KNOWLEGEBASE CONTENT FOR WELL CHILD CARE
D PTED,NUTR,EXAM,DM
Q
;
NUTR ; EP-NUTRITION TOPICS
N DIK,DA
S DIK="^VEN(7.12,"
S DA=0 F S DA=$O(^VEN(7.12,"B",7,DA)) Q:'DA D ^DIK ; CLEAN OUT THE TYPE
D ^XBFMK
N ARR,FILE,TYPE
S FILE="TBLNUT.TXT",TYPE=7
S ARR=$NA(^TMP("VEN KB",$J)) K @ARR
D PE1(FILE) ; BUILD PRIMARY ARRAY
D PASS2
D FILE(TYPE)
K @ARR
D ^XBFMK
Q
;
PTED ; EP-PATIENT ED TOPICS
N DIK,DA
S DIK="^VEN(7.12,"
S DA=0 F S DA=$O(^VEN(7.12,"B",6,DA)) Q:'DA D ^DIK ; CLEAN OUT THE TYPE
D ^XBFMK
N ARR,FILE,TYPE
S FILE="TBLINJURYP.TXT",TYPE=6
S ARR=$NA(^TMP("VEN KB",$J)) K @ARR
D PE1(FILE) ; BUILD PRIMARY ARRAY
D PASS2
D FILE(TYPE)
K @ARR
D ^XBFMK
Q
;
PE1(FILE) ; EP - FIRST PASS FOR PATIENT ED AND NUTRITION TOPICS
N PATH,POP,XCODE,SS,PCE,CNT,REC,TOT
S PATH="C:\ITSC\kb\"
S POP=$$OPN^VENPCCP(PATH,FILE,"R","F CNT=0:1 R REC(CNT) I $L(REC(CNT))<3 K REC(CNT) Q")
S TOT=$L(REC(0),U) I TOT<3 Q
F PCE=1:1:TOT D
. S SS=$P(REC(0),U,PCE)
. I $E(SS,1,3)="i " Q
. S CNT=0
. F S CNT=$O(REC(CNT)) Q:'CNT D
.. S XCODE=$P(REC(CNT),U,PCE)
.. S @ARR@($E(SS,1,30),CNT)=XCODE_U_SS
.. Q
. Q
Q
;
EXAM ; EP-IMPORT EXAM FILE INTO KNOWLEDGE BASE
N DIK,DA
S DIK="^VEN(7.12,"
S DA=0 F S DA=$O(^VEN(7.12,"B",2,DA)) Q:'DA D ^DIK ; CLEAN OUT THE TYPE
D ^XBFMK
N ARR,FILE,TYPE
S FILE="TBLEXAM.TXT",TYPE=2
S ARR=$NA(^TMP("VEN KB",$J)) K @ARR
D PASS1(FILE) ; BUILD PRIMARY ARRAY
D PASS2
D FILE(TYPE)
K @ARR
D ^XBFMK
Q
;
PASS1(FILE) ; EP - GENERATE A PRIMARY ARRAY FROM THE FILE
N PATH,POP,VAL,SS,PCE,CNT,REC,TOT
S PATH="C:\ITSC\kb\"
S POP=$$OPN^VENPCCP(PATH,FILE,"R","F CNT=0:1 R REC(CNT) I $L(REC(CNT))<3 K REC(CNT) Q")
S TOT=$L(REC(0),U) I TOT<3 Q
F PCE=1:1:TOT D
. S SS=$P(REC(0),U,PCE)
. S CNT=0
. F S CNT=$O(REC(CNT)) Q:'CNT D
.. S VAL=$P(REC(CNT),U,PCE)
.. S @ARR@(SS,CNT)=VAL
.. Q
. Q
Q
;
PASS2 ; EP - BUILD SECONDARY ARRAY FOR NON-DEVEL ITEMS
N SS,CNT,START,VAL,STOP
S SS="" F S SS=$O(@ARR@(SS)) Q:SS="" D
. I SS'="AGE",SS'="ID",SS'="test",SS'="test2",SS'="car seats"
. E K @ARR@(SS) Q
. S CNT=0,START=0
. F Q:START S CNT=$O(@ARR@(SS,CNT)) Q:'CNT D
.. S VAL=@ARR@(SS,CNT)
.. I $L($P(VAL,U)) S START=CNT
.. Q
. I 'START Q
. S CNT=999999,STOP=0
. F Q:STOP S CNT=$O(@ARR@(SS,CNT),-1) Q:'CNT D
.. S VAL=@ARR@(SS,CNT)
.. I $L($P(VAL,U)) S STOP=CNT
.. Q
. K @ARR@(SS)
. S @ARR@(SS)=START_U_STOP_U_VAL
. Q
Q
;
FILE(TYPE) ; EP-UPDATE VEN EHP KB ITEM FILE
N DIC,DIE,X,Y,MN,DR,DA,TEXT,CODE,UNIT,STG,Z,SEXSCR,AGE1,AGE2,SEX,%,AX1,AX2,XCODE
S STG=$G(^VEN(7.11,TYPE,0)) I '$L(STG) Q
S MN=$P(STG,U,2) I '$L(MN) Q
S UNIT=$P(STG,U,10) I '$L(UNIT) Q
S SEXSCR=+$P(STG,U,8)
S (DIE,DIC)="^VEN(7.12,",DIC(0)="L",DLAYGO=19707.12
S DR=".02////^S X=TEXT;.03////^S X=CODE;.05////^S X=AGE1;.06////^S X=AGE2;.1////^S X=SEX;"
S DR=DR_".13////^S X=AX1;.14////^S X=AX2;.04////^S X=XCODE"
S TEXT="" F S TEXT=$O(@ARR@(TEXT)) Q:'$L(TEXT) D
. S Z=$G(@ARR@(TEXT)) I '$L(Z) Q
. S AGE1=$P(Z,U) I AGE1=1 S AGE1=0
. S AX1=AGE1
. I AGE1 S AGE1=$$TIME(AGE1,UNIT) I 'AGE1 Q
. S (AX2,AGE2)=$P(Z,U,2)
. S AGE2=$$TIME(AGE2,UNIT) I 'AGE2 Q
. S SEX="" I SEXSCR,TYPE=2 S %=$P(Z,U,3) I %="F"!(%="M") S SEX=%
. S XCODE=""
. I TYPE=6 S XCODE=$P(Z,U,3),TEXT=$P(Z,U,4) ; PT ED FULL TOPIC NAME AND XCODE
. I TYPE=7 S TEXT=$P(Z,U,4) ; NUTRITION FULL TOPIC NAME
. S X="""`"_TYPE_""""
. D ^DIC I Y=-1 Q
. S DA=+Y
. S CODE=MN_DA
. L +^VEN(7.12,DA):0 I $T D ^DIE L -^VEN(7.12,DA)
. Q
Q
;
DM ; EP-DDST MILESTONES
N ARR,FILE,TYPE,NAME
F TYPE=1,3:1:5 S NAME=$P("Fine^^Gross^Lang^Social",U,TYPE) D
. S ARR=$NA(^TMP("VEN KBX",$J)) K @ARR
. S FILE="Tbl"_NAME_".txt"
. D D1(FILE,TYPE)
. S ARR=$NA(^TMP("VEN KB",$J)) K @ARR
. S FILE="TblNo"_NAME_".txt"
. D D1(FILE,TYPE)
. K ^TMP("VEN KBX",$J)
. D DFILE(TYPE)
. K ^TMP("VEN KB",$J)
. D ^XBFMK
. Q
Q
;
D1(FILE,TYPE) ; EP - FIRST DEVELOPMENTAL PASS
I $L($G(FILE)),$D(^VEN(7.11,+$G(TYPE),0))
E Q
N DIK,DA
S DIK="^VEN(7.12,"
S DA=0 F S DA=$O(^VEN(7.12,"B",TYPE,DA)) Q:'DA D ^DIK ; CLEAN OUT THE TYPE
D ^XBFMK
N PATH,POP,PCT,XSTART,XSTOP,SS,PCE,CNT,REC,TOT,AGE,INACTIVE
S PATH="C:\ITSC\kb\"
S POP=$$OPN^VENPCCP(PATH,FILE,"R","F CNT=0:1 R REC(CNT) I $L(REC(CNT))<3 K REC(CNT) Q")
S TOT=$L(REC(0),U) I TOT<3 Q
F PCE=3:1:TOT D ; IGNORE THE 1ST 2 FIELDS
. S SS=$P(REC(0),U,PCE)
. S CNT=0
. F S CNT=$O(REC(CNT)) Q:'CNT D
.. S PCT=$P(REC(CNT),U,PCE) I PCT="" Q ; NULL = DON'T SHOW IT. 0 = INACTIVATE IT.
.. S AGE=$P(REC(CNT),U,2) I AGE="" Q
.. S XSTART=AGE S XSTOP=AGE+.5 I AGE>18 S XSTOP=XSTOP+.5
.. S AGE=$$TIME(AGE,"M")
.. S INACTIVE=($P($G(^TMP("VEN KBX",$J,SS,AGE)),U)=0)
.. S @ARR@(SS,AGE)=PCT_U_INACTIVE_U_XSTART_U_XSTOP
.. Q
. Q
Q
;
DFILE(TYPE) ; EP-FILE DEVELOPMENTAL DATA
N DIC,DIE,X,Y,MN,DR,DA,TEXT,CODE,UNIT,STG,Z,SEXSCR,SEX,%,A1,A2,PCT,INACTIVE,%,XSTART,XSTOP
S STG=$G(^VEN(7.11,TYPE,0)) I '$L(STG) Q
S MN=$P(STG,U,2) I '$L(MN) Q
S (DIE,DIC)="^VEN(7.12,",DIC(0)="L",DLAYGO=19707.12
S DR=".02////^S X=TEXT;.03////^S X=CODE;.05////^S X=A1;.06////^S X=A2;.12////^S X=PCT;"
S DR=DR_".11////^S X=INACTIVE;.13////^S X=XSTART;.14////^S X=XSTOP"
S TEXT=""
F S TEXT=$O(@ARR@(TEXT)) Q:'$L(TEXT) I TEXT'="AGE",TEXT'="ID" S A1=0 F S A1=$O(@ARR@(TEXT,A1)) Q:'A1 D
. S X="""`"_TYPE_""""
. D ^DIC I Y=-1 Q
. S A2=$O(@ARR@(TEXT,A1))
. I A2 S A2=A2-1
. E S A2=A1+15 I A1>550 S A2=A2+15
. S %=$G(@ARR@(TEXT,A1))
. S PCT=+%
. S INACTIVE=$P(%,U,2)
. S XSTART=$P(%,U,3) S XSTOP=$P(%,U,4)
. S DA=+Y
. S CODE=MN_DA
. L +^VEN(7.12,DA):0 I $T D ^DIE L -^VEN(7.12,DA)
. Q
Q
;
TIME(AGE,UNIT) ; EP - CONVERT TIME TO DAYS
I $G(AGE)="" Q ""
I 'AGE Q 0
I '$L($G(UNIT)) Q ""
I UNIT="D" Q AGE
I UNIT="W" Q (AGE*7)
I UNIT="M" Q ((AGE*30.5)\1)
I UNIT="Y" Q ((AGE*365.35)\1)
Q ""
;
TRIG(AGE,IEN,MODE) ; EP - TRIGGER DAYS FROM EXTERNAL AGE
; MODE = 1 START ; MODE = 2 STOP
N CAT,CIEN,DAYS,STG,UNIT,START,STOP
S STG=$G(^VEN(7.12,IEN,0)) I '$L(STG) Q ""
S CIEN=+STG,START=$P(STG,U,5),STOP=$P(STG,U,6)
S CAT=$P($G(^VEN(7.11,CIEN,0)),U) I '$L(CAT) Q ""
I CAT["WELL CHILD DEVEL" Q $S(MODE=1:START,MODE=2:STOP,1:"") ; DONT TRIGGER AGE FOR DEVELOPMENT ITEMS
S UNIT=$P(^VEN(7.11,CIEN,0),U,10) I '$L(UNIT) Q ""
S DAYS=$$TIME(AGE,UNIT)
Q DAYS ; ADD
;
DAYS(DFN) ; EP - GIVEN A DOB, RETURN THE AGE IN DAYS
N DOB
S DOB=$P($G(^DPT(+$G(DFN),0)),U,3)
I '$G(DOB) Q ""
Q $$FMDIFF^XLFDT(DT,DOB,1)
;
TAX(OUT,IN) ; EP - RPC: VEN PCC+ KB TAXONOMY
S OUT="BMX ADO SS^VEN KB TAXONOMY^^~~~~~ITAX~VENPCCK~" ; RETURN ALL TAXONOMIES
Q
;
ITAX(PARAM,IENS,MAX,OUT,TOT) ; EP - RETURN A LIST OF TEMPLATES ASSOCIATED WITH A KB GROUP
N NAME,DA,STG,EX
S EX=$C(68)_" DATA"_U
S EX=EX_"BMXADOV1(IENS,DA)"
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 EX
.. 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 ; EP - FILTERS
N NAME,DA,STG,EX
S EX=$C(68)_" DATA"_U
S EX=EX_"BMXADOV1(IENS,DA)"
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
.. X EX
.. Q
. Q
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
;
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
;
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
;
VENPCCK ; IHS/OIT/GIS - KNOWLEDGE BASE ;
+1 ;;2.6;PCC+;**1,3**;APR 03, 2012;Build 24
+2 ;
+3 ;
+4 ;
+5 ;
FETCH(DEFEF,DFN) ; EP-RETURN KNOWLEDGEBASE DATA
+1 IF '$DATA(^DPT(+$GET(DFN),0))
QUIT
+2 NEW KCIEN,IFLG,KIEN,HDR,IEN,STG,K,AGE,SEX,AGEFLAG,SEXFLAG,LAGFLAG,GESTFLAG,START,STOP,TMP,IX
+3 NEW CNT,TITLE,MOD,TOT,ARR,CAT,TIEN,DOM,ORD,KC,DORD,DIEN,%,LASTCNT,PECODE,AGEGRP
+4 SET TMP=$NAME(^TMP("VEN PRNT",$JOB,1))
+5 ; THERE ARE 2 POSSIBLE DRIVERS TO COLLECT KB ITEMS: LEGACY AND NEW. THE DEFAULT DRIVER IS THE NEW ONE.
+6 ; IF THE DOMAIN MULTIPLE DOES NOT EXIST, USE THE LEGACY DRIVER
IF '$ORDER(^VEN(7.41,DEFEF,19,0))
GOTO LEGACY
NEW ; NEW GUIDELINES DRIVER
SET DIEN=0
+1 ; DOMAIN CONTEXT DRIVER (PREFERRED IF IT EXISTS)
FOR
SET DIEN=$ORDER(^VEN(7.41,DEFEF,19,DIEN))
IF 'DIEN
QUIT
Begin DoDot:1
+2 SET %=$GET(^VEN(7.41,DEFEF,19,DIEN,0))
+3 SET DOM=+%
IF 'DOM
QUIT
+4 ; DOMAIN MUST BE ACTIVE
IF '$PIECE($GET(^VEN(7.13,DOM,0)),U,7)
QUIT
+5 ; NEW DRIVER EXCLUDES PT ED GUIDELINES. THESE ARE HANDLED SEPARATELY
IF $PIECE($GET(^VEN(7.13,DOM,0)),U)["NATL AG"
QUIT
+6 ; EVERY DOMAIN MUST HAVE AN ORDER OR ONE WILL BE ASSIGNED
SET DORD=$PIECE(%,U,2)
IF 'DORD
SET DORD=DIEN+100
+7 SET KC=0
+8 ; CREATE THE ORDINAL ARRAY.
FOR
SET KC=$ORDER(^VEN(7.13,DOM,1,KC))
IF 'KC
QUIT
Begin DoDot:2
+9 SET %=$GET(^VEN(7.13,DOM,1,KC,0))
+10 SET KCIEN=+%
IF 'KCIEN
QUIT
+11 SET ORD=$PIECE(%,U,2)
+12 ; MAKE SURE EVERY CAT HAS AN ORDER - EVEN IF ONE IS NOT OFFICIALLY ASSIGNED
IF 'ORD
SET ORD=100+KC
+13 SET ORD(DORD,ORD)=KCIEN
+14 QUIT
End DoDot:2
+15 QUIT
End DoDot:1
+16 SET DORD=0
SET CNT=0
SET FOR
SET DORD=$ORDER(ORD(DORD))
IF 'DORD
QUIT
Begin DoDot:1
+1 SET ORD=0
FOR
SET ORD=$ORDER(ORD(DORD,ORD))
IF 'ORD
QUIT
Begin DoDot:2
+2 SET KCIEN=ORD(DORD,ORD)
+3 IF 'KCIEN
QUIT
+4 SET LASTCNT=CNT
+5 ; TRAVERSE THE ARRAY TO RETRIEVE CATS
DO GETKBI(KCIEN,.CNT)
+6 QUIT
End DoDot:2
IF CNT>99
QUIT
+7 ; PUT A SPACER LINE BETWEEN DOMAINS
IF LASTCNT'=CNT
SET CNT=CNT+1
SET @TMP@("k"_CNT)="."
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
LEGACY ; EP-IF THE DOMAIN CONTEXT IS NOT DEFINED, USE THE LEGACY DRIVER BEASED ON THE KB MULTIPLE IN THE TEMPLATE FILE
+1 ; FOR BACKWARD COMPATIBILITY ONLY. THIS WILL BE PHASED OUT
+2 ; IF THERE ARE NO KB ITEMS ASOCIATED WITH THE CURRENT FORM QUIT
IF '$ORDER(^VEN(7.41,+$GET(DEFEF),16,0))
QUIT
+3 NEW CNT,TIEN,KCIEN,CNT
+4 SET TIEN=0
SET CNT=0
+5 ; LEGACY DRIVER FROM VER 2.5
FOR
SET TIEN=$ORDER(^VEN(7.41,DEFEF,16,TIEN))
IF 'TIEN
QUIT
Begin DoDot:1
+6 SET KCIEN=$GET(^VEN(7.41,+$GET(DEFEF),16,TIEN,0))
+7 IF 'KCIEN
QUIT
+8 ; GET INFO ABOUT KNOWLEDGE CATEGORY
DO GETKBI(KCIEN,.CNT)
+9 QUIT
End DoDot:1
IF CNT>99
QUIT
+10 QUIT
+11 ;
GETKBI(KCIEN,CNT) ; EP - GET KB ITEMS FROM A SPECIFIC CATEGORY
+1 NEW AGE
+2 SET K=$GET(^VEN(7.11,KCIEN,0))
IF '$LENGTH(K)
QUIT
+3 SET CAT=$PIECE(K,U)
IF '$LENGTH(CAT)
QUIT
+4 SET HDR=$PIECE(K,U,9)
+5 SET CNT=CNT+1
IF CNT>100
QUIT
+6 ; SCREEN BY AGE
SET AGEFLAG=$PIECE(K,U,5)
+7 IF AGEFLAG
SET AGE=$$DAYS(DFN)
IF 'AGE
QUIT
+8 ; SCREEN BY WKS GESTATION
SET GESTFLAG=$PIECE(K,U,6)
+9 ; SCREEN BY TIME SINCE LAST
SET LAGFLAG=$PIECE(K,U,7)
+10 ; SCREEN BY SEX
SET SEXFLAG=$PIECE(K,U,8)
+11 IF SEXFLAG
SET SEX=$PIECE($GET(^DPT(+$GET(DFN),0)),U,2)
IF '$LENGTH(SEX)
QUIT
+12 IF $GET(AGE)
SET PECODE=$PIECE(K,U,13)
IF $LENGTH(PECODE)
Begin DoDot:1
+13 SET Z=AGE
SET AGEGRP=$SELECT(Z<62:"N",Z<366:"I",Z<1096:"T",Z<1827:"P",Z<4384:"S",Z<7686:"A",1:"")
+14 IF '$LENGTH(AGEGRP)
QUIT
+15 SET HDR=HDR_" ("_PECODE_"-"_AGEGRP_")"
+16 QUIT
End DoDot:1
+17 ; SET THE HEADER NODE FOR THIS SET OF ITEMS
SET @TMP@("k"_CNT)=HDR
+18 SET KIEN=0
SET TOT=0
KILL ARR
+19 ; CHECK EA. ENTRY IN THE KNOWLEDGE CATEGORY
FOR
SET KIEN=$ORDER(^VEN(7.12,"B",KCIEN,KIEN))
IF 'KIEN
QUIT
Begin DoDot:1
+20 SET STG=$GET(^VEN(7.12,KIEN,0))
IF '$LENGTH(STG)
QUIT
+21 ; INACTIVE ITEM !!!
IF $PIECE(STG,U,11)
QUIT
+22 IF AGEFLAG
SET START=$PIECE(STG,U,5)
IF AGE<START
QUIT
+23 IF AGEFLAG
SET STOP=$PIECE(STG,U,6)
IF AGE>STOP
QUIT
+24 IF SEXFLAG
SET %=$PIECE(STG,U,10)
IF $LENGTH(%)
IF %'=SEX
QUIT
+25 SET TITLE=$PIECE(STG,U,2)
IF '$LENGTH(TITLE)
QUIT
+26 ; FOR PT ED, APPEND LAST PT ED RESULTS TO TITLE
IF CAT["WCAG "!(CAT["WCEX ")
DO LAST(KCIEN,KIEN,DFN,.TITLE)
+27 SET MOD=$PIECE(STG,U,12)
+28 IF $LENGTH(MOD)
SET TITLE=TITLE_" ("_MOD_")"
+29 IF MOD
IF ($PIECE($GET(^VEN(7.12,KIEN,0)),U,16)!(CAT["WELL CHILD DEVEL")!(CAT["WCDA "))
Begin DoDot:2
+30 SET TOT=TOT+1
+31 SET ARR(MOD,TOT)="__ "_TITLE
+32 SET ARR(MOD,TOT,"IX")=KIEN
+33 QUIT
End DoDot:2
QUIT
+34 ; NO SECONDARY SORT REQUIRED
+35 SET CNT=CNT+1
SET TOT=TOT+1
+36 ; SET THE ITEM NODE
SET @TMP@("k"_CNT)="__ "_TITLE
+37 ; ITEM IEN X-REF
SET @TMP@("k"_CNT,"IX")=KIEN
+38 QUIT
End DoDot:1
IF CNT>99
QUIT
NOITEMS ; NO ITEMS FOUND IN THIS CATEGORY, SO DELETE IT
IF 'TOT
KILL @TMP@("k"_CNT)
SET CNT=CNT-1
QUIT
+1 ; SORT BY %ILE
IF $DATA(ARR)
Begin DoDot:1
+2 SET MOD=999
+3 FOR
SET MOD=$ORDER(ARR(MOD),-1)
IF 'MOD
QUIT
SET TOT=0
FOR
SET TOT=$ORDER(ARR(MOD,TOT))
IF 'TOT
QUIT
Begin DoDot:2
+4 SET CNT=CNT+1
+5 SET @TMP@("k"_CNT)=ARR(MOD,TOT)
+6 SET @TMP@("k"_CNT,"IX")=ARR(MOD,TOT,"IX")
+7 QUIT
End DoDot:2
IF CNT>99
QUIT
+8 KILL ARR
+9 QUIT
End DoDot:1
KX QUIT
+1 ;
LAST(KCIEN,KIEN,DFN,TITLE) ; EP - GET LAST RESULT AND APPEND TO RESULT
+1 NEW MAXIDT,LASTDT,LASTRES,TXT,%
+2 ; GO BACK UP TO 2 YEARS
SET MAXIDT=9999999-(DT-20000)
+3 SET TXT=TITLE
+4 IF $EXTRACT(TXT,1,3)="__ "
SET TXT=$EXTRACT(TXT,4,999)
+5 DO LAST^VENPCCKX(KIEN,KCIEN,TXT,DFN,MAXIDT,.LASTDT,.LASTRES)
+6 IF '$GET(LASTDT)
QUIT
+7 SET %=$$FMTE^XLFDT(LASTDT,2)
IF '$LENGTH(%)
QUIT
+8 IF $LENGTH($GET(LASTRES))
SET %=%_" "_LASTRES
+9 SET TITLE=TITLE_" ("_%_")"
+10 QUIT
+11 ;
IMPORT ; EP-IMPORT KNOWLEGEBASE CONTENT FOR WELL CHILD CARE
+1 DO PTED
DO NUTR
DO EXAM
DO DM
+2 QUIT
+3 ;
NUTR ; EP-NUTRITION TOPICS
+1 NEW DIK,DA
+2 SET DIK="^VEN(7.12,"
+3 ; CLEAN OUT THE TYPE
SET DA=0
FOR
SET DA=$ORDER(^VEN(7.12,"B",7,DA))
IF 'DA
QUIT
DO ^DIK
+4 DO ^XBFMK
+5 NEW ARR,FILE,TYPE
+6 SET FILE="TBLNUT.TXT"
SET TYPE=7
+7 SET ARR=$NAME(^TMP("VEN KB",$JOB))
KILL @ARR
+8 ; BUILD PRIMARY ARRAY
DO PE1(FILE)
+9 DO PASS2
+10 DO FILE(TYPE)
+11 KILL @ARR
+12 DO ^XBFMK
+13 QUIT
+14 ;
PTED ; EP-PATIENT ED TOPICS
+1 NEW DIK,DA
+2 SET DIK="^VEN(7.12,"
+3 ; CLEAN OUT THE TYPE
SET DA=0
FOR
SET DA=$ORDER(^VEN(7.12,"B",6,DA))
IF 'DA
QUIT
DO ^DIK
+4 DO ^XBFMK
+5 NEW ARR,FILE,TYPE
+6 SET FILE="TBLINJURYP.TXT"
SET TYPE=6
+7 SET ARR=$NAME(^TMP("VEN KB",$JOB))
KILL @ARR
+8 ; BUILD PRIMARY ARRAY
DO PE1(FILE)
+9 DO PASS2
+10 DO FILE(TYPE)
+11 KILL @ARR
+12 DO ^XBFMK
+13 QUIT
+14 ;
PE1(FILE) ; EP - FIRST PASS FOR PATIENT ED AND NUTRITION TOPICS
+1 NEW PATH,POP,XCODE,SS,PCE,CNT,REC,TOT
+2 SET PATH="C:\ITSC\kb\"
+3 SET POP=$$OPN^VENPCCP(PATH,FILE,"R","F CNT=0:1 R REC(CNT) I $L(REC(CNT))<3 K REC(CNT) Q")
+4 SET TOT=$LENGTH(REC(0),U)
IF TOT<3
QUIT
+5 FOR PCE=1:1:TOT
Begin DoDot:1
+6 SET SS=$PIECE(REC(0),U,PCE)
+7 IF $EXTRACT(SS,1,3)="i "
QUIT
+8 SET CNT=0
+9 FOR
SET CNT=$ORDER(REC(CNT))
IF 'CNT
QUIT
Begin DoDot:2
+10 SET XCODE=$PIECE(REC(CNT),U,PCE)
+11 SET @ARR@($EXTRACT(SS,1,30),CNT)=XCODE_U_SS
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 QUIT
+15 ;
EXAM ; EP-IMPORT EXAM FILE INTO KNOWLEDGE BASE
+1 NEW DIK,DA
+2 SET DIK="^VEN(7.12,"
+3 ; CLEAN OUT THE TYPE
SET DA=0
FOR
SET DA=$ORDER(^VEN(7.12,"B",2,DA))
IF 'DA
QUIT
DO ^DIK
+4 DO ^XBFMK
+5 NEW ARR,FILE,TYPE
+6 SET FILE="TBLEXAM.TXT"
SET TYPE=2
+7 SET ARR=$NAME(^TMP("VEN KB",$JOB))
KILL @ARR
+8 ; BUILD PRIMARY ARRAY
DO PASS1(FILE)
+9 DO PASS2
+10 DO FILE(TYPE)
+11 KILL @ARR
+12 DO ^XBFMK
+13 QUIT
+14 ;
PASS1(FILE) ; EP - GENERATE A PRIMARY ARRAY FROM THE FILE
+1 NEW PATH,POP,VAL,SS,PCE,CNT,REC,TOT
+2 SET PATH="C:\ITSC\kb\"
+3 SET POP=$$OPN^VENPCCP(PATH,FILE,"R","F CNT=0:1 R REC(CNT) I $L(REC(CNT))<3 K REC(CNT) Q")
+4 SET TOT=$LENGTH(REC(0),U)
IF TOT<3
QUIT
+5 FOR PCE=1:1:TOT
Begin DoDot:1
+6 SET SS=$PIECE(REC(0),U,PCE)
+7 SET CNT=0
+8 FOR
SET CNT=$ORDER(REC(CNT))
IF 'CNT
QUIT
Begin DoDot:2
+9 SET VAL=$PIECE(REC(CNT),U,PCE)
+10 SET @ARR@(SS,CNT)=VAL
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
PASS2 ; EP - BUILD SECONDARY ARRAY FOR NON-DEVEL ITEMS
+1 NEW SS,CNT,START,VAL,STOP
+2 SET SS=""
FOR
SET SS=$ORDER(@ARR@(SS))
IF SS=""
QUIT
Begin DoDot:1
+3 IF SS'="AGE"
IF SS'="ID"
IF SS'="test"
IF SS'="test2"
IF SS'="car seats"
+4 IF '$TEST
KILL @ARR@(SS)
QUIT
+5 SET CNT=0
SET START=0
+6 FOR
IF START
QUIT
SET CNT=$ORDER(@ARR@(SS,CNT))
IF 'CNT
QUIT
Begin DoDot:2
+7 SET VAL=@ARR@(SS,CNT)
+8 IF $LENGTH($PIECE(VAL,U))
SET START=CNT
+9 QUIT
End DoDot:2
+10 IF 'START
QUIT
+11 SET CNT=999999
SET STOP=0
+12 FOR
IF STOP
QUIT
SET CNT=$ORDER(@ARR@(SS,CNT),-1)
IF 'CNT
QUIT
Begin DoDot:2
+13 SET VAL=@ARR@(SS,CNT)
+14 IF $LENGTH($PIECE(VAL,U))
SET STOP=CNT
+15 QUIT
End DoDot:2
+16 KILL @ARR@(SS)
+17 SET @ARR@(SS)=START_U_STOP_U_VAL
+18 QUIT
End DoDot:1
+19 QUIT
+20 ;
FILE(TYPE) ; EP-UPDATE VEN EHP KB ITEM FILE
+1 NEW DIC,DIE,X,Y,MN,DR,DA,TEXT,CODE,UNIT,STG,Z,SEXSCR,AGE1,AGE2,SEX,%,AX1,AX2,XCODE
+2 SET STG=$GET(^VEN(7.11,TYPE,0))
IF '$LENGTH(STG)
QUIT
+3 SET MN=$PIECE(STG,U,2)
IF '$LENGTH(MN)
QUIT
+4 SET UNIT=$PIECE(STG,U,10)
IF '$LENGTH(UNIT)
QUIT
+5 SET SEXSCR=+$PIECE(STG,U,8)
+6 SET (DIE,DIC)="^VEN(7.12,"
SET DIC(0)="L"
SET DLAYGO=19707.12
+7 SET DR=".02////^S X=TEXT;.03////^S X=CODE;.05////^S X=AGE1;.06////^S X=AGE2;.1////^S X=SEX;"
+8 SET DR=DR_".13////^S X=AX1;.14////^S X=AX2;.04////^S X=XCODE"
+9 SET TEXT=""
FOR
SET TEXT=$ORDER(@ARR@(TEXT))
IF '$LENGTH(TEXT)
QUIT
Begin DoDot:1
+10 SET Z=$GET(@ARR@(TEXT))
IF '$LENGTH(Z)
QUIT
+11 SET AGE1=$PIECE(Z,U)
IF AGE1=1
SET AGE1=0
+12 SET AX1=AGE1
+13 IF AGE1
SET AGE1=$$TIME(AGE1,UNIT)
IF 'AGE1
QUIT
+14 SET (AX2,AGE2)=$PIECE(Z,U,2)
+15 SET AGE2=$$TIME(AGE2,UNIT)
IF 'AGE2
QUIT
+16 SET SEX=""
IF SEXSCR
IF TYPE=2
SET %=$PIECE(Z,U,3)
IF %="F"!(%="M")
SET SEX=%
+17 SET XCODE=""
+18 ; PT ED FULL TOPIC NAME AND XCODE
IF TYPE=6
SET XCODE=$PIECE(Z,U,3)
SET TEXT=$PIECE(Z,U,4)
+19 ; NUTRITION FULL TOPIC NAME
IF TYPE=7
SET TEXT=$PIECE(Z,U,4)
+20 SET X="""`"_TYPE_""""
+21 DO ^DIC
IF Y=-1
QUIT
+22 SET DA=+Y
+23 SET CODE=MN_DA
+24 LOCK +^VEN(7.12,DA):0
IF $TEST
DO ^DIE
LOCK -^VEN(7.12,DA)
+25 QUIT
End DoDot:1
+26 QUIT
+27 ;
DM ; EP-DDST MILESTONES
+1 NEW ARR,FILE,TYPE,NAME
+2 FOR TYPE=1,3:1:5
SET NAME=$PIECE("Fine^^Gross^Lang^Social",U,TYPE)
Begin DoDot:1
+3 SET ARR=$NAME(^TMP("VEN KBX",$JOB))
KILL @ARR
+4 SET FILE="Tbl"_NAME_".txt"
+5 DO D1(FILE,TYPE)
+6 SET ARR=$NAME(^TMP("VEN KB",$JOB))
KILL @ARR
+7 SET FILE="TblNo"_NAME_".txt"
+8 DO D1(FILE,TYPE)
+9 KILL ^TMP("VEN KBX",$JOB)
+10 DO DFILE(TYPE)
+11 KILL ^TMP("VEN KB",$JOB)
+12 DO ^XBFMK
+13 QUIT
End DoDot:1
+14 QUIT
+15 ;
D1(FILE,TYPE) ; EP - FIRST DEVELOPMENTAL PASS
+1 IF $LENGTH($GET(FILE))
IF $DATA(^VEN(7.11,+$GET(TYPE),0))
+2 IF '$TEST
QUIT
+3 NEW DIK,DA
+4 SET DIK="^VEN(7.12,"
+5 ; CLEAN OUT THE TYPE
SET DA=0
FOR
SET DA=$ORDER(^VEN(7.12,"B",TYPE,DA))
IF 'DA
QUIT
DO ^DIK
+6 DO ^XBFMK
+7 NEW PATH,POP,PCT,XSTART,XSTOP,SS,PCE,CNT,REC,TOT,AGE,INACTIVE
+8 SET PATH="C:\ITSC\kb\"
+9 SET POP=$$OPN^VENPCCP(PATH,FILE,"R","F CNT=0:1 R REC(CNT) I $L(REC(CNT))<3 K REC(CNT) Q")
+10 SET TOT=$LENGTH(REC(0),U)
IF TOT<3
QUIT
+11 ; IGNORE THE 1ST 2 FIELDS
FOR PCE=3:1:TOT
Begin DoDot:1
+12 SET SS=$PIECE(REC(0),U,PCE)
+13 SET CNT=0
+14 FOR
SET CNT=$ORDER(REC(CNT))
IF 'CNT
QUIT
Begin DoDot:2
+15 ; NULL = DON'T SHOW IT. 0 = INACTIVATE IT.
SET PCT=$PIECE(REC(CNT),U,PCE)
IF PCT=""
QUIT
+16 SET AGE=$PIECE(REC(CNT),U,2)
IF AGE=""
QUIT
+17 SET XSTART=AGE
SET XSTOP=AGE+.5
IF AGE>18
SET XSTOP=XSTOP+.5
+18 SET AGE=$$TIME(AGE,"M")
+19 SET INACTIVE=($PIECE($GET(^TMP("VEN KBX",$JOB,SS,AGE)),U)=0)
+20 SET @ARR@(SS,AGE)=PCT_U_INACTIVE_U_XSTART_U_XSTOP
+21 QUIT
End DoDot:2
+22 QUIT
End DoDot:1
+23 QUIT
+24 ;
DFILE(TYPE) ; EP-FILE DEVELOPMENTAL DATA
+1 NEW DIC,DIE,X,Y,MN,DR,DA,TEXT,CODE,UNIT,STG,Z,SEXSCR,SEX,%,A1,A2,PCT,INACTIVE,%,XSTART,XSTOP
+2 SET STG=$GET(^VEN(7.11,TYPE,0))
IF '$LENGTH(STG)
QUIT
+3 SET MN=$PIECE(STG,U,2)
IF '$LENGTH(MN)
QUIT
+4 SET (DIE,DIC)="^VEN(7.12,"
SET DIC(0)="L"
SET DLAYGO=19707.12
+5 SET DR=".02////^S X=TEXT;.03////^S X=CODE;.05////^S X=A1;.06////^S X=A2;.12////^S X=PCT;"
+6 SET DR=DR_".11////^S X=INACTIVE;.13////^S X=XSTART;.14////^S X=XSTOP"
+7 SET TEXT=""
+8 FOR
SET TEXT=$ORDER(@ARR@(TEXT))
IF '$LENGTH(TEXT)
QUIT
IF TEXT'="AGE"
IF TEXT'="ID"
SET A1=0
FOR
SET A1=$ORDER(@ARR@(TEXT,A1))
IF 'A1
QUIT
Begin DoDot:1
+9 SET X="""`"_TYPE_""""
+10 DO ^DIC
IF Y=-1
QUIT
+11 SET A2=$ORDER(@ARR@(TEXT,A1))
+12 IF A2
SET A2=A2-1
+13 IF '$TEST
SET A2=A1+15
IF A1>550
SET A2=A2+15
+14 SET %=$GET(@ARR@(TEXT,A1))
+15 SET PCT=+%
+16 SET INACTIVE=$PIECE(%,U,2)
+17 SET XSTART=$PIECE(%,U,3)
SET XSTOP=$PIECE(%,U,4)
+18 SET DA=+Y
+19 SET CODE=MN_DA
+20 LOCK +^VEN(7.12,DA):0
IF $TEST
DO ^DIE
LOCK -^VEN(7.12,DA)
+21 QUIT
End DoDot:1
+22 QUIT
+23 ;
TIME(AGE,UNIT) ; EP - CONVERT TIME TO DAYS
+1 IF $GET(AGE)=""
QUIT ""
+2 IF 'AGE
QUIT 0
+3 IF '$LENGTH($GET(UNIT))
QUIT ""
+4 IF UNIT="D"
QUIT AGE
+5 IF UNIT="W"
QUIT (AGE*7)
+6 IF UNIT="M"
QUIT ((AGE*30.5)\1)
+7 IF UNIT="Y"
QUIT ((AGE*365.35)\1)
+8 QUIT ""
+9 ;
TRIG(AGE,IEN,MODE) ; EP - TRIGGER DAYS FROM EXTERNAL AGE
+1 ; MODE = 1 START ; MODE = 2 STOP
+2 NEW CAT,CIEN,DAYS,STG,UNIT,START,STOP
+3 SET STG=$GET(^VEN(7.12,IEN,0))
IF '$LENGTH(STG)
QUIT ""
+4 SET CIEN=+STG
SET START=$PIECE(STG,U,5)
SET STOP=$PIECE(STG,U,6)
+5 SET CAT=$PIECE($GET(^VEN(7.11,CIEN,0)),U)
IF '$LENGTH(CAT)
QUIT ""
+6 ; DONT TRIGGER AGE FOR DEVELOPMENT ITEMS
IF CAT["WELL CHILD DEVEL"
QUIT $SELECT(MODE=1:START,MODE=2:STOP,1:"")
+7 SET UNIT=$PIECE(^VEN(7.11,CIEN,0),U,10)
IF '$LENGTH(UNIT)
QUIT ""
+8 SET DAYS=$$TIME(AGE,UNIT)
+9 ; ADD
QUIT DAYS
+10 ;
DAYS(DFN) ; EP - GIVEN A DOB, RETURN THE AGE IN DAYS
+1 NEW DOB
+2 SET DOB=$PIECE($GET(^DPT(+$GET(DFN),0)),U,3)
+3 IF '$GET(DOB)
QUIT ""
+4 QUIT $$FMDIFF^XLFDT(DT,DOB,1)
+5 ;
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 ;
ITAX(PARAM,IENS,MAX,OUT,TOT) ; EP - RETURN A LIST OF TEMPLATES ASSOCIATED WITH A KB GROUP
+1 NEW NAME,DA,STG,EX
+2 SET EX=$CHAR(68)_" DATA"_U
+3 SET EX=EX_"BMXADOV1(IENS,DA)"
+4 SET NAME=""
+5 FOR
SET NAME=$ORDER(^ATXAX("B",NAME))
IF NAME=""
QUIT
Begin DoDot:1
+6 SET DA=0
+7 FOR
SET DA=$ORDER(^ATXAX("B",NAME,DA))
IF 'DA
QUIT
Begin DoDot:2
+8 ; MUST BE AN ICD TAXONOMY
IF $PIECE($GET(^ATXAX(DA,0)),U,15)'=80
QUIT
+9 XECUTE EX
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT ""
+13 ;
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 ; EP - FILTERS
+1 NEW NAME,DA,STG,EX
+2 SET EX=$CHAR(68)_" DATA"_U
+3 SET EX=EX_"BMXADOV1(IENS,DA)"
+4 IF '$DATA(^VEN(7.11,+$DATA(KGIEN),0))
QUIT
+5 SET NAME=""
+6 FOR
SET NAME=$ORDER(^VEN(7.41,"B",NAME))
IF NAME=""
QUIT
Begin DoDot:1
+7 SET DA=0
+8 FOR
SET DA=$ORDER(^VEN(7.41,"B",NAME,DA))
IF 'DA
QUIT
Begin DoDot:2
+9 ; 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
+10 ; 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
+11 XECUTE EX
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 QUIT
+15 ;
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 ;
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 ;
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 ;
