VENPCCKT.m

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