VENPCCKT ; IHS/OIT/GIS - GUI TRANSACTION MANAGER - PT ED, NUTR AND EXAMS ;
;;2.6;PCC+;**1,3**;APR 03, 2012;Build 24
;
;
;
EXPOP(IN) ; EP - POPULATE THE EXAM TOPICS
N DFN,LINE,CNT,VIEN,DIK,DA,KEY,TYPE,STOP,SS
K LINE D VAR I '$D(LINE) Q
S (LINE,CNT)=0
EX1 I LINE="" G EX2
S STOP=0
F S LINE=$O(LINE(LINE)) Q:'LINE D I STOP Q ; GET STARTING LINE FOR EXAM SUBCATEGORY
. S SS=""
. I LINE(LINE)="AGE-SPECIFIC EXAMS" S STOP=1,SS=6 Q
. I LINE(LINE)="GENERAL HEALTH SCREEN" S STOP=1,SS=8 Q
. I LINE(LINE)="SPECIAL RISK SCREEN" S STOP=1,SS=4 Q
. I LINE(LINE)="BEHAVIORAL HEALTH SCREEN" S STOP=1,SS=7 Q
. Q
EX2 I 'LINE!('$G(SS)) D Q ; QUIT IF NO MORE EXAM ITEMS EXIST
. I CNT S OUT="BMX ADO SS^VEN WCM TX^^AC~"_KEY_"~"_KEY_"~9999"
. D ^XBFMK
. Q
D CAT(.LINE,.CNT,3,SS) ; PROCESS EXAM SUBCATEGORY
G EX1 ; GET NEXT EXAM SUBCATEGORY
;
PEPOP(IN) ; EP - POPULATE NUTR TOPICS OR PT ED TOPICS
N DFN,LINE,CNT,VIEN,DIK,DA,KEY,TYPE
D VAR
S LINE=0,CNT=0
PE1 I LINE="" G PE2
F S LINE=$O(LINE(LINE)) Q:'LINE I $E(LINE(LINE),1,8)="PT ED - " Q ; GET STARTING LINE FOR A PT ED SUBCATEGORY
PE2 I 'LINE D Q ; QUIT IF NO MORE PT ED ITEMS EXIST
. I CNT S OUT="BMX ADO SS^VEN WCM TX^^AC~"_KEY_"~"_KEY_"~9999"
. D ^XBFMK
. Q
D CAT(.LINE,.CNT,TYPE) ; PROCESS SUBCATEGORY
G PE1 ; GET NEXT SUB-CATEGORY OF PT ED TOPICS
;
VAR ; EP - SET UP MAIN VARIABLES, CLEANUP TRANSACTION FILE AND CREATE THE RAW DATA ARRAY
D STALE ; FIRST, CLEAN UP TX FILE BY REMOVING STALE ENTRIES
S OUT=""
S VIEN=+$G(IN) I '$D(^AUPNVSIT(VIEN,0)) Q
S TYPE=$P(IN,"|",2) I '$L(TYPE) Q
S DFN=+$P($G(^AUPNVSIT(VIEN,0)),U,5) I '$D(^DPT(DFN,0)) Q
S KEY=VIEN_"_"_TYPE,DIK="^VEN(7.16,",DA=0
F S DA=$O(^VEN(7.16,"AC",KEY,DA)) Q:'DA D ^DIK ; CLEANUP ALL TXS RELATED TO THIS VISIT
D ARR(DFN,.LINE) ; GET THE RAW ARRAY IN LINE()
Q
;
CAT(LINE,CNT,TYPE,SS) ; EP - PROCESS A PT ED SUB-CATEGORY AND POPULATE THE TX FILE
N %,CAT,CIEN,ITEM,DIC,DA,DR,X,Y,Z,%,EDATE,VAL,STG,STOP,CODE,DIK,GBL,IIEN,LAST,KIEN,SEL,RES,IX
VARS I 16[TYPE D
. S %=$E(LINE(LINE),9,99)
. S %=$E(%,1,$L(%)-1) I '$L(%) Q
. S %="WCAG "_%
. Q
I TYPE=3 S %="WCEX "_LINE(LINE),%=$E(%,1,$L(%)-1) I '$L(%) Q
S CAT=$O(^VEN(7.11,"B",%)) I CAT'[% Q
S CIEN=$O(^VEN(7.11,"B",CAT,0)) I 'CIEN Q
S STOP=0
S DIC="^VEN(7.16,",DLAYGO=19707.16,DIC(0)="L"
S SS=$S(16[TYPE:1,$G(SS):SS,1:"") I 'SS Q ; SUBSCRIPT FOR FILING RESULTS
LINE F S LINE=$O(LINE(LINE)) Q:LINE="" D I STOP Q ; PROCESS EACH LINE IN THE ARRAY
IVARS . S STG=LINE(LINE)
. I $E(STG,1,3)'="__ " S LINE=LINE-1,STOP=1 Q
. S (IX,ITEM)=$P(STG,". ",2,99) I '$L(ITEM) Q
. S IIEN=$P(ITEM,"|",2),ITEM=$P(ITEM,"|")
. S KIEN=+$G(^VEN(7.12,IIEN,0)) I 'KIEN Q
. I TYPE'=3,$P($G(^VEN(7.11,KIEN,0)),U,11)'=TYPE Q ; PT ED CATEGORY TYPE MUST MATCH
INIT . S (CODE,SEL,RES,LAST)="" ; INITIALIZE OPTIONAL VARS
CODE . I 16[TYPE S CODE=$P($G(^VEN(7.12,IIEN,2)),U,3) ; PT ED CODE
PAST . S %=$RE(ITEM) ; PARSE LAST DATE/RESULT
. I TYPE=3,$E(%,1,7)=")LAMRON" D ; FOR EXAMS, PEEL OFF THE RESULT VALUE
.. S RES=$P(ITEM," ",$L(ITEM," ")) ; GET DATE OF LAST INSTANCE
.. S RES=$E(RES)
.. S %=")"_$P(%," ",2,99)
.. Q
. I $E(%,1,4)?1")"2N1"/" D ; FOR PT ED AND EXAMS, STRIP OFF DATE
.. S X=$P(%,"( ",2,99),ITEM=$RE(X),IX=$E(ITEM,1,30) ; IX IS THE LOOKUP NAME, ITEM IS THE FULL TEXT
.. S Y=$P(%,"( "),Y=$E(Y,2,999),LAST=$RE(Y) ; DATE OF LAST ENTRY
.. Q
. I $L(LAST) S X=LAST D ^%DT I Y=DT S (LAST,RES)="" ; TODAY'S RESULTS SHOULD ARE "CURRENT", NOT "LAST"
CURRENT . S SEL=$$SEL(DFN,IX,TYPE,$G(SS)) ; GET TODAY'S SELECTION, IF IT EXISTS
DIC . S X=""""_CIEN_""""
. D ^DIC I Y=-1 Q
. S DA=+Y,GBL=$NA(^VEN(7.16))
. S @GBL@(DA,0)=CIEN_U_CAT_U_IIEN_U_ITEM_U_CODE_U_LAST_U_SEL_U_VIEN_U_TYPE_U_KEY_U_RES_U_DT_U_SS ; TX RECORD
. S @GBL@("AC",KEY,DA)="",@GBL@("AD",DT,DA)="" ; INDEXES
. S CNT=CNT+1
. Q
D ^XBFMK
Q
;
SEL(DFN,ITEM,TYPE,SS) ; EP - SEE IF THIS ITEM IS ALREADY IN TODAY'S V WELL CHILD RECORD
N SEL,DA,X,%,IDT
S SEL="",IDT=9999999-DT
I $G(ITEM)="" Q ""
S DA=$O(^AUPNVWC("AA",DFN,IDT,0)) I 'DA Q ""
I 16[$G(TYPE),$D(^AUPNVWC(DA,1,"B",ITEM)) S SEL=1 Q SEL ; TODAY'S PT ED
I TYPE=3,$G(SS) D ; TODAY'S EXAM RESULT
. S %=$O(^AUPNVWC(DA,SS,"B",ITEM,0)) I '% Q
. S SEL=$P($G(^AUPNVWC(DA,SS,%,0)),U,2)
. Q
Q SEL
;
ARR(DFN,LINE) ; EP - RETURN THE LINE ARRAY USED IN GENERATING THE HEALTH SUMMARY SEGMENT ;
N DOB,DAYS,SEX,GUIFLAG
S LINE=0
S GUIFLAG=1 ; TELLS THE ARRAY GENERATOR TO PREVENT TODAY'S RESULTS FROM BEING RETURNED AS A "LAST" RESULT
S DOB=$P($G(^DPT(+DFN,0)),U,3) I 'DOB Q
S SEX=$P($G(^DPT(+DFN,0)),U,2) I '$L(SEX) Q
S DAYS=$$FMDIFF^XLFDT(DT,DOB,1) I 'DAYS Q
D REM^APCHS6B(DFN,-1,SEX,DAYS) ; GET REMINDER LIST FOR EA KB CATEGORY
Q
;
EXFLUSH(IN) ; EP - FLUSH EXAM TXS TO V WELL CHILD
; IN = VIEN
I '$D(^AUPNVSIT(+$G(IN),0)) Q ; A VALID VISIT MUST EXIST
N APCDVSIT,AUPNPAT,KEY,TXIEN,STG,X,Y,Z,%,TOT,SS,RES,ARR
S OUT=""
S APCDVSIT=+IN ; VISIT IEN
S KEY=APCDVSIT_"_3" ; LOOKUP KEY
S AUPNPAT=+$P($G(^AUPNVSIT(APCDVSIT,0)),U,5) I '$D(^DPT(AUPNPAT,0)) Q ; PATIENT DFN
S TXIEN=0,TOT=0
F S TXIEN=$O(^VEN(7.16,"AC",KEY,TXIEN)) Q:'TXIEN D ; BUILD THE RESULTS ARRAY
. S STG=$G(^VEN(7.16,TXIEN,0))
. S RES=$P(STG,U,7) I RES="" Q ; ITEM MUST HAVE A RESULT
. S SS=$P(STG,U,13) I 'SS Q ; ITEM MUST HAVE A FILING SUBSCRIPT
. S TITLE=$P(STG,U,4) I '$L(TITLE) Q ; MUST HAVE A VALID TITLE
. S TOT=TOT+1 ; KEEP TRACK OF THE TOT NUMBER OF VALID TITLES ENTERED
. S ARR(TOT)=TITLE,ARR(TOT,1)=RES
. Q
I 'TOT D TXCLEAN Q ; NOTHING SELECTED, SO CLEAN UP AND QUIT
EXVF D EVWCFILE^VENPCCQC(SS,1) ; FILE EXAMS IN V WC
D TXCLEAN
S OUT="OK"
Q
;
PEFLUSH(IN) ; EP - FLUSH DATA FOR PT ED AND NUTR TRANSACTIONS TO V FILES
; IN = TYPE|VISIT IEN|LOU|TIME|EDUCATOR IEN|INFANT FEEDING CHOICE
I '$L($G(IN)) Q
N APCDVSIT,AUPNPAT,DA,TXIEN,STG,X,Y,Z,%,TOT,TITLE,CODE,LOU,TIME,EDU,ARR,FTIME,CNT,OK,CIEN,KEY,TYPE,IFC
FVAR ; GET FLUSH VARIABLES
S OUT=""
S TYPE=$P(IN,"|") I 'TYPE Q ; TYPE
S APCDVSIT=+$P(IN,"|",2) I '$D(^AUPNVSIT(APCDVSIT,0)) Q ; VISIT IEN
S KEY=APCDVSIT_"_"_TYPE ; LOOKUP KEY
S AUPNPAT=+$P($G(^AUPNVSIT(APCDVSIT,0)),U,5) I '$D(^DPT(AUPNPAT,0)) Q ; PATIENT DFN
S LOU=$P(IN,"|",3) ; LEVEL OF UNDERSTANDING
I $L(LOU)>1,"POORFAIRGOODNAREFUSED"[LOU
E S LOU=""
S EDU=$P(IN,"|",5) I '$D(^VA(200,EDU,0)) S EDU="" ; EDUCATOR
FARR ; BUILD THE FLUSH ARRAY
S TXIEN=0,TOT=0
F S TXIEN=$O(^VEN(7.16,"AC",KEY,TXIEN)) Q:'TXIEN D
. S STG=$G(^VEN(7.16,TXIEN,0))
. I '$P(STG,U,7) Q ; ITEM MUST BE SELECTED
. S TITLE=$P(STG,U,4) I '$L(TITLE) Q ; MUST HAVE A VALID TITLE
. S CODE=$P(STG,U,5) I '$L(CODE) Q
. S CIEN=$$CODE^VENPCCQC(CODE) I 'CIEN Q ; CAN'TY FIND A VALID INSTANCE OF THE PT ED CODE, SO QUIT
. S TOT=TOT+1 ; KEEP TRACK OF THE TOT NUMBER OF VALID TITLES ENTERED
. S ARR(TOT)=TITLE,ARR(TOT,1)="",ARR("CODE",CODE,TOT)=TITLE,ARR("CAT",CIEN)=""
. Q
I 'TOT G TXCLEAN ; NOTHING SELECTED
TIME ; GET EDU TIME AND FRACTIONAL TIME
S TIME=$P(IN,"|",4) ; TOTAL PATIENT ED TIME
I TIME=+TIME,TIME=TIME\1,TIME>0,TIME<999 D I 1 ; VALIDATE TIME
. I TYPE=6 S FTIME=TIME Q
. S CIEN=0 F CNT=0:1 S CIEN=$O(ARR("CAT",CIEN)) Q:'CIEN ; COUNT THE NUMBER OF KB CATEGORIES
. I CNT S FTIME=TIME\CNT ; FRACTONAL TIME (AVERAGED ACROSS ALL PT ED CATEGORIES)
. Q
E S (FTIME,TIME)=""
VPED ; UPDATE V PAT ED
D VPEFILE^VENPCCQC(LOU,FTIME,EDU)
VWC ; UPDATE V WELL CHILD
I TYPE=1 D PEWCFILE^VENPCCQC(LOU,TIME,EDU) S OUT="OK" G TXCLEAN
I TYPE=6 D NVWCFILE^VENPCCQC(LOU,TIME,EDU)
VIFC S IFC=$P(IN,"|",6) I $L(IFC) D ; UPDATE V INFANT FEEDING CHOICE
. S IFC=$$UP^XLFSTR(IFC)
. S IFC=$S(IFC["EXCLU":1,IFC["LY BR":2,IFC["1/2":3,IFC["LY FO":4,IFC["LA ON":5,1:"")
. I 'IFC Q
. S DIC="^AUPNVIF(",DIC(0)="L",DLAYGO=9000010.44,X="""`"_IFC_""""
. D ^DIC I Y=-1 Q
. S DIE=DIC,DA=+Y,DR=".02////^S X=AUPNPAT;.03////^S X=APCDVSIT"
. L +^AUPNVIF(DA):1 I D ^DIE L -^AUPNVIF(DA)
. Q
S OUT="OK"
TXCLEAN S DA=0,DIK="^VEN(7.16," F S DA=$O(^VEN(7.16,"AC",KEY,DA)) Q:'DA D ^DIK ; EP - CLEAN UP THE TX FILE
D ^XBFMK
Q
;
TODAY(DFN,TYPE) ; EP - RETURNS TODAY'S PT ED/NURT RESULTS - IF THERE ARE ANY
S TYPE=$G(TYPE) I TYPE'="P",TYPE'="N" Q
I '$D(^DPT(+$G(DFN,0))) Q
N VIEN,PRV,PRVIEN,LOU,TIME,IFC,X,Y,%,VWCIEN,STOP,VDATE,B,IFCIEN
S (OUT,PRV,PRVIEN,LOU,TIME,IFC)="",B="|"
S VWCIEN=99999999,STOP=0
F S VWCIEN=$O(^AUPNVWC("AC",DFN,VWCIEN),-1) Q:'VWCIEN D I STOP Q
. S X=$G(^AUPNVWC(VWCIEN,0)) I '$L(X) Q
. S VIEN=$P(X,U,3) I 'VIEN Q
. S VDATE=+$G(^AUPNVSIT(VIEN,0)) I 'VDATE Q
. I VDATE<DT S STOP=1 Q
. S STOP=1,OUT=VIEN
. I TYPE="P",'$D(^AUPNVWC(VWCIEN,1)) Q
. I TYPE="N",'$D(^AUPNVWC(VWCIEN,5)) Q
. I TYPE="P" S PRVIEN=$P(X,U,4),TIME=$P(X,U,5),LOU=$P(X,U,6)
. I TYPE="N" D
.. S PRVIEN=$P(X,U,9),TIME=$P(X,U,7),LOU=$P(X,U,8)
.. S IFCIEN=$O(^AUPNVIF("AD",VIEN,0))
.. I IFCIEN S IFC=+$G(^AUPNVIF(IFCIEN,0))
.. Q
. I PRVIEN S PRV=$P($G(^VA(200,PRVIEN,0)),U)
. I LOU S LOU=$P("GOOD^FAIR^POOR^NA^REFUSED",U,LOU)
. I $G(IFC) S IFC=$P("EXCLUSIVE BREASTFEEDING^MOSTLY BREASTFEEDING^1/2 & 1/2 BREAST AND FORMULA^MOSTLY FORMULA^FORMULA ONLY",U,IFC)
. S OUT=VIEN_B_PRV_B_PRVIEN_B_LOU_B_TIME
. I TYPE="N" S OUT=OUT_B_IFC
. Q
Q
;
STALE ; EP - REMOVE STALE ENTRIES FROM TX FILE ; TRANSACTION FROM EARLIER DATES ARE, BY DEFINITION, ORPHANS
N DATE,DIK,DA
S DATE=DT,DIK="^VEN(7.16,"
F S DATE=$O(^VEN(7.16,"AD",DATE),-1) Q:'DATE D
. S DA=0
. F S DA=$O(^VEN(7.16,"AD",DATE,DA)) Q:'DA D ^DIK
. Q
D ^XBFMK
Q
;
VENPCCKT ; IHS/OIT/GIS - GUI TRANSACTION MANAGER - PT ED, NUTR AND EXAMS ;
+1 ;;2.6;PCC+;**1,3**;APR 03, 2012;Build 24
+2 ;
+3 ;
+4 ;
EXPOP(IN) ; EP - POPULATE THE EXAM TOPICS
+1 NEW DFN,LINE,CNT,VIEN,DIK,DA,KEY,TYPE,STOP,SS
+2 KILL LINE
DO VAR
IF '$DATA(LINE)
QUIT
+3 SET (LINE,CNT)=0
EX1 IF LINE=""
GOTO EX2
+1 SET STOP=0
+2 ; GET STARTING LINE FOR EXAM SUBCATEGORY
FOR
SET LINE=$ORDER(LINE(LINE))
IF 'LINE
QUIT
Begin DoDot:1
+3 SET SS=""
+4 IF LINE(LINE)="AGE-SPECIFIC EXAMS"
SET STOP=1
SET SS=6
QUIT
+5 IF LINE(LINE)="GENERAL HEALTH SCREEN"
SET STOP=1
SET SS=8
QUIT
+6 IF LINE(LINE)="SPECIAL RISK SCREEN"
SET STOP=1
SET SS=4
QUIT
+7 IF LINE(LINE)="BEHAVIORAL HEALTH SCREEN"
SET STOP=1
SET SS=7
QUIT
+8 QUIT
End DoDot:1
IF STOP
QUIT
EX2 ; QUIT IF NO MORE EXAM ITEMS EXIST
IF 'LINE!('$GET(SS))
Begin DoDot:1
+1 IF CNT
SET OUT="BMX ADO SS^VEN WCM TX^^AC~"_KEY_"~"_KEY_"~9999"
+2 DO ^XBFMK
+3 QUIT
End DoDot:1
QUIT
+4 ; PROCESS EXAM SUBCATEGORY
DO CAT(.LINE,.CNT,3,SS)
+5 ; GET NEXT EXAM SUBCATEGORY
GOTO EX1
+6 ;
PEPOP(IN) ; EP - POPULATE NUTR TOPICS OR PT ED TOPICS
+1 NEW DFN,LINE,CNT,VIEN,DIK,DA,KEY,TYPE
+2 DO VAR
+3 SET LINE=0
SET CNT=0
PE1 IF LINE=""
GOTO PE2
+1 ; GET STARTING LINE FOR A PT ED SUBCATEGORY
FOR
SET LINE=$ORDER(LINE(LINE))
IF 'LINE
QUIT
IF $EXTRACT(LINE(LINE),1,8)="PT ED - "
QUIT
PE2 ; QUIT IF NO MORE PT ED ITEMS EXIST
IF 'LINE
Begin DoDot:1
+1 IF CNT
SET OUT="BMX ADO SS^VEN WCM TX^^AC~"_KEY_"~"_KEY_"~9999"
+2 DO ^XBFMK
+3 QUIT
End DoDot:1
QUIT
+4 ; PROCESS SUBCATEGORY
DO CAT(.LINE,.CNT,TYPE)
+5 ; GET NEXT SUB-CATEGORY OF PT ED TOPICS
GOTO PE1
+6 ;
VAR ; EP - SET UP MAIN VARIABLES, CLEANUP TRANSACTION FILE AND CREATE THE RAW DATA ARRAY
+1 ; FIRST, CLEAN UP TX FILE BY REMOVING STALE ENTRIES
DO STALE
+2 SET OUT=""
+3 SET VIEN=+$GET(IN)
IF '$DATA(^AUPNVSIT(VIEN,0))
QUIT
+4 SET TYPE=$PIECE(IN,"|",2)
IF '$LENGTH(TYPE)
QUIT
+5 SET DFN=+$PIECE($GET(^AUPNVSIT(VIEN,0)),U,5)
IF '$DATA(^DPT(DFN,0))
QUIT
+6 SET KEY=VIEN_"_"_TYPE
SET DIK="^VEN(7.16,"
SET DA=0
+7 ; CLEANUP ALL TXS RELATED TO THIS VISIT
FOR
SET DA=$ORDER(^VEN(7.16,"AC",KEY,DA))
IF 'DA
QUIT
DO ^DIK
+8 ; GET THE RAW ARRAY IN LINE()
DO ARR(DFN,.LINE)
+9 QUIT
+10 ;
CAT(LINE,CNT,TYPE,SS) ; EP - PROCESS A PT ED SUB-CATEGORY AND POPULATE THE TX FILE
+1 NEW %,CAT,CIEN,ITEM,DIC,DA,DR,X,Y,Z,%,EDATE,VAL,STG,STOP,CODE,DIK,GBL,IIEN,LAST,KIEN,SEL,RES,IX
VARS IF 16[TYPE
Begin DoDot:1
+1 SET %=$EXTRACT(LINE(LINE),9,99)
+2 SET %=$EXTRACT(%,1,$LENGTH(%)-1)
IF '$LENGTH(%)
QUIT
+3 SET %="WCAG "_%
+4 QUIT
End DoDot:1
+5 IF TYPE=3
SET %="WCEX "_LINE(LINE)
SET %=$EXTRACT(%,1,$LENGTH(%)-1)
IF '$LENGTH(%)
QUIT
+6 SET CAT=$ORDER(^VEN(7.11,"B",%))
IF CAT'[%
QUIT
+7 SET CIEN=$ORDER(^VEN(7.11,"B",CAT,0))
IF 'CIEN
QUIT
+8 SET STOP=0
+9 SET DIC="^VEN(7.16,"
SET DLAYGO=19707.16
SET DIC(0)="L"
+10 ; SUBSCRIPT FOR FILING RESULTS
SET SS=$SELECT(16[TYPE:1,$GET(SS):SS,1:"")
IF 'SS
QUIT
LINE ; PROCESS EACH LINE IN THE ARRAY
FOR
SET LINE=$ORDER(LINE(LINE))
IF LINE=""
QUIT
Begin DoDot:1
IVARS SET STG=LINE(LINE)
+1 IF $EXTRACT(STG,1,3)'="__ "
SET LINE=LINE-1
SET STOP=1
QUIT
+2 SET (IX,ITEM)=$PIECE(STG,". ",2,99)
IF '$LENGTH(ITEM)
QUIT
+3 SET IIEN=$PIECE(ITEM,"|",2)
SET ITEM=$PIECE(ITEM,"|")
+4 SET KIEN=+$GET(^VEN(7.12,IIEN,0))
IF 'KIEN
QUIT
+5 ; PT ED CATEGORY TYPE MUST MATCH
IF TYPE'=3
IF $PIECE($GET(^VEN(7.11,KIEN,0)),U,11)'=TYPE
QUIT
INIT ; INITIALIZE OPTIONAL VARS
SET (CODE,SEL,RES,LAST)=""
CODE ; PT ED CODE
IF 16[TYPE
SET CODE=$PIECE($GET(^VEN(7.12,IIEN,2)),U,3)
PAST ; PARSE LAST DATE/RESULT
SET %=$REVERSE(ITEM)
+1 ; FOR EXAMS, PEEL OFF THE RESULT VALUE
IF TYPE=3
IF $EXTRACT(%,1,7)=")LAMRON"
Begin DoDot:2
+2 ; GET DATE OF LAST INSTANCE
SET RES=$PIECE(ITEM," ",$LENGTH(ITEM," "))
+3 SET RES=$EXTRACT(RES)
+4 SET %=")"_$PIECE(%," ",2,99)
+5 QUIT
End DoDot:2
+6 ; FOR PT ED AND EXAMS, STRIP OFF DATE
IF $EXTRACT(%,1,4)?1")"2N1"/"
Begin DoDot:2
+7 ; IX IS THE LOOKUP NAME, ITEM IS THE FULL TEXT
SET X=$PIECE(%,"( ",2,99)
SET ITEM=$REVERSE(X)
SET IX=$EXTRACT(ITEM,1,30)
+8 ; DATE OF LAST ENTRY
SET Y=$PIECE(%,"( ")
SET Y=$EXTRACT(Y,2,999)
SET LAST=$REVERSE(Y)
+9 QUIT
End DoDot:2
+10 ; TODAY'S RESULTS SHOULD ARE "CURRENT", NOT "LAST"
IF $LENGTH(LAST)
SET X=LAST
DO ^%DT
IF Y=DT
SET (LAST,RES)=""
CURRENT ; GET TODAY'S SELECTION, IF IT EXISTS
SET SEL=$$SEL(DFN,IX,TYPE,$GET(SS))
DIC SET X=""""_CIEN_""""
+1 DO ^DIC
IF Y=-1
QUIT
+2 SET DA=+Y
SET GBL=$NAME(^VEN(7.16))
+3 ; TX RECORD
SET @GBL@(DA,0)=CIEN_U_CAT_U_IIEN_U_ITEM_U_CODE_U_LAST_U_SEL_U_VIEN_U_TYPE_U_KEY_U_RES_U_DT_U_SS
+4 ; INDEXES
SET @GBL@("AC",KEY,DA)=""
SET @GBL@("AD",DT,DA)=""
+5 SET CNT=CNT+1
+6 QUIT
End DoDot:1
IF STOP
QUIT
+7 DO ^XBFMK
+8 QUIT
+9 ;
SEL(DFN,ITEM,TYPE,SS) ; EP - SEE IF THIS ITEM IS ALREADY IN TODAY'S V WELL CHILD RECORD
+1 NEW SEL,DA,X,%,IDT
+2 SET SEL=""
SET IDT=9999999-DT
+3 IF $GET(ITEM)=""
QUIT ""
+4 SET DA=$ORDER(^AUPNVWC("AA",DFN,IDT,0))
IF 'DA
QUIT ""
+5 ; TODAY'S PT ED
IF 16[$GET(TYPE)
IF $DATA(^AUPNVWC(DA,1,"B",ITEM))
SET SEL=1
QUIT SEL
+6 ; TODAY'S EXAM RESULT
IF TYPE=3
IF $GET(SS)
Begin DoDot:1
+7 SET %=$ORDER(^AUPNVWC(DA,SS,"B",ITEM,0))
IF '%
QUIT
+8 SET SEL=$PIECE($GET(^AUPNVWC(DA,SS,%,0)),U,2)
+9 QUIT
End DoDot:1
+10 QUIT SEL
+11 ;
ARR(DFN,LINE) ; EP - RETURN THE LINE ARRAY USED IN GENERATING THE HEALTH SUMMARY SEGMENT ;
+1 NEW DOB,DAYS,SEX,GUIFLAG
+2 SET LINE=0
+3 ; TELLS THE ARRAY GENERATOR TO PREVENT TODAY'S RESULTS FROM BEING RETURNED AS A "LAST" RESULT
SET GUIFLAG=1
+4 SET DOB=$PIECE($GET(^DPT(+DFN,0)),U,3)
IF 'DOB
QUIT
+5 SET SEX=$PIECE($GET(^DPT(+DFN,0)),U,2)
IF '$LENGTH(SEX)
QUIT
+6 SET DAYS=$$FMDIFF^XLFDT(DT,DOB,1)
IF 'DAYS
QUIT
+7 ; GET REMINDER LIST FOR EA KB CATEGORY
DO REM^APCHS6B(DFN,-1,SEX,DAYS)
+8 QUIT
+9 ;
EXFLUSH(IN) ; EP - FLUSH EXAM TXS TO V WELL CHILD
+1 ; IN = VIEN
+2 ; A VALID VISIT MUST EXIST
IF '$DATA(^AUPNVSIT(+$GET(IN),0))
QUIT
+3 NEW APCDVSIT,AUPNPAT,KEY,TXIEN,STG,X,Y,Z,%,TOT,SS,RES,ARR
+4 SET OUT=""
+5 ; VISIT IEN
SET APCDVSIT=+IN
+6 ; LOOKUP KEY
SET KEY=APCDVSIT_"_3"
+7 ; PATIENT DFN
SET AUPNPAT=+$PIECE($GET(^AUPNVSIT(APCDVSIT,0)),U,5)
IF '$DATA(^DPT(AUPNPAT,0))
QUIT
+8 SET TXIEN=0
SET TOT=0
+9 ; BUILD THE RESULTS ARRAY
FOR
SET TXIEN=$ORDER(^VEN(7.16,"AC",KEY,TXIEN))
IF 'TXIEN
QUIT
Begin DoDot:1
+10 SET STG=$GET(^VEN(7.16,TXIEN,0))
+11 ; ITEM MUST HAVE A RESULT
SET RES=$PIECE(STG,U,7)
IF RES=""
QUIT
+12 ; ITEM MUST HAVE A FILING SUBSCRIPT
SET SS=$PIECE(STG,U,13)
IF 'SS
QUIT
+13 ; MUST HAVE A VALID TITLE
SET TITLE=$PIECE(STG,U,4)
IF '$LENGTH(TITLE)
QUIT
+14 ; KEEP TRACK OF THE TOT NUMBER OF VALID TITLES ENTERED
SET TOT=TOT+1
+15 SET ARR(TOT)=TITLE
SET ARR(TOT,1)=RES
+16 QUIT
End DoDot:1
+17 ; NOTHING SELECTED, SO CLEAN UP AND QUIT
IF 'TOT
DO TXCLEAN
QUIT
EXVF ; FILE EXAMS IN V WC
DO EVWCFILE^VENPCCQC(SS,1)
+1 DO TXCLEAN
+2 SET OUT="OK"
+3 QUIT
+4 ;
PEFLUSH(IN) ; EP - FLUSH DATA FOR PT ED AND NUTR TRANSACTIONS TO V FILES
+1 ; IN = TYPE|VISIT IEN|LOU|TIME|EDUCATOR IEN|INFANT FEEDING CHOICE
+2 IF '$LENGTH($GET(IN))
QUIT
+3 NEW APCDVSIT,AUPNPAT,DA,TXIEN,STG,X,Y,Z,%,TOT,TITLE,CODE,LOU,TIME,EDU,ARR,FTIME,CNT,OK,CIEN,KEY,TYPE,IFC
FVAR ; GET FLUSH VARIABLES
+1 SET OUT=""
+2 ; TYPE
SET TYPE=$PIECE(IN,"|")
IF 'TYPE
QUIT
+3 ; VISIT IEN
SET APCDVSIT=+$PIECE(IN,"|",2)
IF '$DATA(^AUPNVSIT(APCDVSIT,0))
QUIT
+4 ; LOOKUP KEY
SET KEY=APCDVSIT_"_"_TYPE
+5 ; PATIENT DFN
SET AUPNPAT=+$PIECE($GET(^AUPNVSIT(APCDVSIT,0)),U,5)
IF '$DATA(^DPT(AUPNPAT,0))
QUIT
+6 ; LEVEL OF UNDERSTANDING
SET LOU=$PIECE(IN,"|",3)
+7 IF $LENGTH(LOU)>1
IF "POORFAIRGOODNAREFUSED"[LOU
+8 IF '$TEST
SET LOU=""
+9 ; EDUCATOR
SET EDU=$PIECE(IN,"|",5)
IF '$DATA(^VA(200,EDU,0))
SET EDU=""
FARR ; BUILD THE FLUSH ARRAY
+1 SET TXIEN=0
SET TOT=0
+2 FOR
SET TXIEN=$ORDER(^VEN(7.16,"AC",KEY,TXIEN))
IF 'TXIEN
QUIT
Begin DoDot:1
+3 SET STG=$GET(^VEN(7.16,TXIEN,0))
+4 ; ITEM MUST BE SELECTED
IF '$PIECE(STG,U,7)
QUIT
+5 ; MUST HAVE A VALID TITLE
SET TITLE=$PIECE(STG,U,4)
IF '$LENGTH(TITLE)
QUIT
+6 SET CODE=$PIECE(STG,U,5)
IF '$LENGTH(CODE)
QUIT
+7 ; CAN'TY FIND A VALID INSTANCE OF THE PT ED CODE, SO QUIT
SET CIEN=$$CODE^VENPCCQC(CODE)
IF 'CIEN
QUIT
+8 ; KEEP TRACK OF THE TOT NUMBER OF VALID TITLES ENTERED
SET TOT=TOT+1
+9 SET ARR(TOT)=TITLE
SET ARR(TOT,1)=""
SET ARR("CODE",CODE,TOT)=TITLE
SET ARR("CAT",CIEN)=""
+10 QUIT
End DoDot:1
+11 ; NOTHING SELECTED
IF 'TOT
GOTO TXCLEAN
TIME ; GET EDU TIME AND FRACTIONAL TIME
+1 ; TOTAL PATIENT ED TIME
SET TIME=$PIECE(IN,"|",4)
+2 ; VALIDATE TIME
IF TIME=+TIME
IF TIME=TIME\1
IF TIME>0
IF TIME<999
Begin DoDot:1
+3 IF TYPE=6
SET FTIME=TIME
QUIT
+4 ; COUNT THE NUMBER OF KB CATEGORIES
SET CIEN=0
FOR CNT=0:1
SET CIEN=$ORDER(ARR("CAT",CIEN))
IF 'CIEN
QUIT
+5 ; FRACTONAL TIME (AVERAGED ACROSS ALL PT ED CATEGORIES)
IF CNT
SET FTIME=TIME\CNT
+6 QUIT
End DoDot:1
IF 1
+7 IF '$TEST
SET (FTIME,TIME)=""
VPED ; UPDATE V PAT ED
+1 DO VPEFILE^VENPCCQC(LOU,FTIME,EDU)
VWC ; UPDATE V WELL CHILD
+1 IF TYPE=1
DO PEWCFILE^VENPCCQC(LOU,TIME,EDU)
SET OUT="OK"
GOTO TXCLEAN
+2 IF TYPE=6
DO NVWCFILE^VENPCCQC(LOU,TIME,EDU)
VIFC ; UPDATE V INFANT FEEDING CHOICE
SET IFC=$PIECE(IN,"|",6)
IF $LENGTH(IFC)
Begin DoDot:1
+1 SET IFC=$$UP^XLFSTR(IFC)
+2 SET IFC=$SELECT(IFC["EXCLU":1,IFC["LY BR":2,IFC["1/2":3,IFC["LY FO":4,IFC["LA ON":5,1:"")
+3 IF 'IFC
QUIT
+4 SET DIC="^AUPNVIF("
SET DIC(0)="L"
SET DLAYGO=9000010.44
SET X="""`"_IFC_""""
+5 DO ^DIC
IF Y=-1
QUIT
+6 SET DIE=DIC
SET DA=+Y
SET DR=".02////^S X=AUPNPAT;.03////^S X=APCDVSIT"
+7 LOCK +^AUPNVIF(DA):1
IF $TEST
DO ^DIE
LOCK -^AUPNVIF(DA)
+8 QUIT
End DoDot:1
+9 SET OUT="OK"
TXCLEAN ; EP - CLEAN UP THE TX FILE
SET DA=0
SET DIK="^VEN(7.16,"
FOR
SET DA=$ORDER(^VEN(7.16,"AC",KEY,DA))
IF 'DA
QUIT
DO ^DIK
+1 DO ^XBFMK
+2 QUIT
+3 ;
TODAY(DFN,TYPE) ; EP - RETURNS TODAY'S PT ED/NURT RESULTS - IF THERE ARE ANY
+1 SET TYPE=$GET(TYPE)
IF TYPE'="P"
IF TYPE'="N"
QUIT
+2 IF '$DATA(^DPT(+$GET(DFN,0)))
QUIT
+3 NEW VIEN,PRV,PRVIEN,LOU,TIME,IFC,X,Y,%,VWCIEN,STOP,VDATE,B,IFCIEN
+4 SET (OUT,PRV,PRVIEN,LOU,TIME,IFC)=""
SET B="|"
+5 SET VWCIEN=99999999
SET STOP=0
+6 FOR
SET VWCIEN=$ORDER(^AUPNVWC("AC",DFN,VWCIEN),-1)
IF 'VWCIEN
QUIT
Begin DoDot:1
+7 SET X=$GET(^AUPNVWC(VWCIEN,0))
IF '$LENGTH(X)
QUIT
+8 SET VIEN=$PIECE(X,U,3)
IF 'VIEN
QUIT
+9 SET VDATE=+$GET(^AUPNVSIT(VIEN,0))
IF 'VDATE
QUIT
+10 IF VDATE<DT
SET STOP=1
QUIT
+11 SET STOP=1
SET OUT=VIEN
+12 IF TYPE="P"
IF '$DATA(^AUPNVWC(VWCIEN,1))
QUIT
+13 IF TYPE="N"
IF '$DATA(^AUPNVWC(VWCIEN,5))
QUIT
+14 IF TYPE="P"
SET PRVIEN=$PIECE(X,U,4)
SET TIME=$PIECE(X,U,5)
SET LOU=$PIECE(X,U,6)
+15 IF TYPE="N"
Begin DoDot:2
+16 SET PRVIEN=$PIECE(X,U,9)
SET TIME=$PIECE(X,U,7)
SET LOU=$PIECE(X,U,8)
+17 SET IFCIEN=$ORDER(^AUPNVIF("AD",VIEN,0))
+18 IF IFCIEN
SET IFC=+$GET(^AUPNVIF(IFCIEN,0))
+19 QUIT
End DoDot:2
+20 IF PRVIEN
SET PRV=$PIECE($GET(^VA(200,PRVIEN,0)),U)
+21 IF LOU
SET LOU=$PIECE("GOOD^FAIR^POOR^NA^REFUSED",U,LOU)
+22 IF $GET(IFC)
SET IFC=$PIECE("EXCLUSIVE BREASTFEEDING^MOSTLY BREASTFEEDING^1/2 & 1/2 BREAST AND FORMULA^MOSTLY FORMULA^FORMULA ONLY",U,IFC)
+23 SET OUT=VIEN_B_PRV_B_PRVIEN_B_LOU_B_TIME
+24 IF TYPE="N"
SET OUT=OUT_B_IFC
+25 QUIT
End DoDot:1
IF STOP
QUIT
+26 QUIT
+27 ;
STALE ; EP - REMOVE STALE ENTRIES FROM TX FILE ; TRANSACTION FROM EARLIER DATES ARE, BY DEFINITION, ORPHANS
+1 NEW DATE,DIK,DA
+2 SET DATE=DT
SET DIK="^VEN(7.16,"
+3 FOR
SET DATE=$ORDER(^VEN(7.16,"AD",DATE),-1)
IF 'DATE
QUIT
Begin DoDot:1
+4 SET DA=0
+5 FOR
SET DA=$ORDER(^VEN(7.16,"AD",DATE,DA))
IF 'DA
QUIT
DO ^DIK
+6 QUIT
End DoDot:1
+7 DO ^XBFMK
+8 QUIT
+9 ;
