APCDTWC.m

APCDTWC ; IHS/CMI/LAB - GENERATED FROM 'APCD WCE (ADD)' INPUT TEMPLATE(#XXX), FILE 9000010 ; 

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 ; WELL CHILD EXAM INPUT TEMPLATE FOR PCC AND PCC+

 ; 

 ;

DATA I '$D(^DPT(+$G(AUPNPAT),0)) Q  ; DFN MUST BE DEFINED

 I '$G(^AUPNVSIT(+$G(APCDVSIT),0)) Q  ; VISIT MUST BE DEFINED

 I $O(^VEN(7.12)),$O(^VEN(7.13))

 E  D  Q

 . W !,"Sorry, if you want to use this Mnemonic,"

 . W !,"the PCC+ Knowledgebase must be installed."

 . W !,"Request cancelled..."

 . H 1

 . Q

 W !!!,?15,"***  DATA ENTRY - WELL CHILD EXAM  ***"

 K Y ; PREVENT THE "An error has occurred, I think" message.

NEW N DIR,DIC,DIE,DA,X,Y,%,%T,%,%Y,%DT,VDATE

 S VDATE=^AUPNVSIT(APCDVSIT,0)\1 I 'VDATE Q  ; VISIT DATE MUST EXIST

 S DIR("B")="A" ; ONLY SET DEFAULT TO "A" ON THE FIRST PASS

MENU ; MAIN DATA ENTRY MENU FOR WELL CHILD CARE VISIT

 S DIR(0)="S^1:Clinic;2:Provider;3:POV;4:Development/Autism Screen comments;5:Patient education;6:Nutrition;7:Screening exams;8:ASQ score;A:ALL items;Q:QUIT THIS MNEMONIC"

 S DIR("A")="Your choice" D ^DIR K DIR

 I Y="A" D ALL G MENU  ; EDIT THE V OB RECORD

 I '$G(Y) G FIN  ; BAIL OUT

 D @$P("CLN^PRV^POV^DEV^PTED^NUT^EXAM^ASQ",U,Y) W !! G MENU

FIN D ^XBFMK

 Q

 ;

TEST N AUPNPAT,APCDVSIT S AUPNPAT=1,AUPNVSIT=71262 D APCDTWC Q

 ; 

ALL ; EDIT ALL SECTIONS

 D CLN,PRV,POV,DEV,PTED,NUT,EXAM,ASQ

 Q

 ;

CLN ; EDIT CLINIC

 N CIEN,CLN,DA,DIE,DR,%,DIC,X,Y

 S CIEN=$O(^DIC(40.7,"C",24,0)),CLN=""

 I 'CIEN S CLN="GENERAL"

 I CIEN S CLN=$P($G(^DIC(40.7,CIEN,0)),U)

 S %=$P($G(^AUPNVSIT(APCDVSIT,0)),U,8) I % S CLN=$P($G(^DIC(40.7,%,0)),U)

 S DIE="^AUPNVSIT(",DA=APCDVSIT,DR=".08//"_CLN

 L +^AUPNVSIT(APCDVSIT):1 I  D ^DIE L -^AUPNVSIT(APCDVSIT)

 Q

 ;

PRV ; ENTER THE PROVIDERS

 N DIC,DA,DR,DIE,X,Y,%,PS

 S %=0,X=0

 F  S X=$O(^AUPNVPRV("AD",APCDVSIT,X)) Q:'X  I $E($P($G(^AUPNVPRV(X,0)),U,4))="P" S %=1 Q

 I %=1 W !,"A primary provider has already been entered for this visit..." G PRV2

 S DIC("A")="Provider: "

 S PS="PRIMARY"

PRVQ S DIC=200,DIC(0)="AEQM"

 I $P($G(^DD(9000010.06,.01,0)),U,2)[6 S DIC=6

 D ^DIC I Y=-1 D ^XBFMK Q

 S %=0,X=0

 F  S X=$O(^AUPNVPRV("AD",APCDVSIT,X)) Q:'X  I +$G(^AUPNVPRV(X,0))=+Y S %=1 Q

 I %=1 W !,"This provider has already been entered for this visit..." G PRV2

PRV1 S DIC="^AUPNVPRV(",DIC(0)="L",DLAYGO=9000010.06,X="""`"_+Y_""""

 D ^DIC I Y=-1 D ^XBFMK Q

 S DA=+Y,DIE=DIC,DR=".02////^S X=AUPNPAT;.03////^S X=APCDVSIT;.04//"_PS

 L +^AUPNVPRV(DA):1 I  D ^DIE L -^AUPNVPRV(DA)

PRV2 S PS="SECONDARY"

 S DIC("A")="Another provider: "

 G PRVQ ; GET MORE

 ;

POV ; PURPOSE OF VISIT

 N DA

 S DA=APCDVSIT

 I $D(^AUPNVPOV("AD",DA)) G POV1 ; THERE IS ALREADY A POV FOR THIS VISIT

 N DIC,DIE,DR,X,Y,%,DIR,NIEN,IIEN

 S DIC="^AUTNPOV(",DIC(0)="L",DLAYGO=9999999.27,X="WELL CHILD EXAM"

 D ^DIC I Y=-1 G POVX

 S NIEN=+Y ; GET IEN FOR 'WELL CHILD EXAM' PROVIDER NARRATIVE

 S X=$O(^ICD9("AB","V20.2",0)) I 'X S X=$O(^ICD9("AB","V20.2 ",0)) I 'X G POVX ; GET THE ICD9 IEN FOR A WELL CHILD EXAM

 S DIC="^AUPNVPOV(",DIC(0)="L",DLAYGO=9000010.07,X="""`"_X_""""

 D ^DIC I Y=-1 G POVX ; CREATE NEW POV ENTRY

 S DA=+Y,DIE=DIC,DR=".02////^S X=AUPNPAT;.03////^S X=APCDVSIT;.04////^S X=NIEN;.12////P"

 L +^AUPNVPOV(DA):1 I  D ^DIE L -^AUPNVPOV(DA)

POV1 W !!,"***  WELL CHILD EXAM (V20.2) has been automatically added as a POV  ***"

 W !,"Add additional POV's using the PV mnemonic",! Q

POVX W !,"Unable to automatically add WELL CHILD EXAM as a POV!!!"

 Q

 ; 

DEV ; ENTER DEVELOPMENT ASSESSMENT

 N DEV,DA,DIR,DIE,DR,VAL1,VAL2,VAL3,VAL4,FNO,TOT,X,Y,VWCIEN,%,%Y

 S X=$O(^VEN(7.13,"B","WELL CHILD NATL DEV STDS 9999"),-1) Q:X=""  S Y=$O(^(X,0)) I 'Y Q

 I '$P($G(^VEN(7.13,Y,0)),U,7) W !,"No DEV guidelines available..." Q  ; DEV DOMAIN IS INACIVE

 S VWCIEN=$O(^AUPNVWC("AD",APCDVSIT,999999999),-1)

 W !!,"Want to enter Development or Autism screen comments" S %=2

 D YN^DICN I %'=1 Q

 S DIR(0)="FO^1:60",DIR("A")="Fine motor"

 S DIR("B")="OK"

 I VWCIEN S %=$P($G(^AUPNVWC(VWCIEN,3)),U,1) I $L(%) S DIR("B")=%

 D ^DIR K DIR I Y?1."^" G DEVX

 I $L(Y) S DEV(3.01)=Y

 S DIR(0)="FO^1:60",DIR("A")="Gross motor"

 S DIR("B")="OK"

 I VWCIEN S %=$P($G(^AUPNVWC(VWCIEN,3)),U,2) I $L(%) S DIR("B")=%

 D ^DIR K DIR I Y?1."^" G DEVX

 I $L(Y) S DEV(3.02)=Y

 S DIR(0)="FO^1:60",DIR("A")="Language"

 S DIR("B")="OK"

 I VWCIEN S %=$P($G(^AUPNVWC(VWCIEN,3)),U,3) I $L(%) S DIR("B")=%

 D ^DIR K DIR I Y?1."^" G DEVX

 I $L(Y) S DEV(3.03)=Y

 S DIR(0)="FO^1:60",DIR("A")="Social"

 S DIR("B")="OK"

 I VWCIEN S %=$P($G(^AUPNVWC(VWCIEN,3)),U,4) I $L(%) S DIR("B")=%

 D ^DIR K DIR I Y?1."^" G DEVX

 I $L(Y) S DEV(3.04)=Y

 S DIR(0)="FO^1:60",DIR("A")="Autism screen"

 S DIR("B")="OK"

 I VWCIEN S %=$P($G(^AUPNVWC(VWCIEN,9)),U,1) I $L(%) S DIR("B")=%

 D ^DIR K DIR I Y?1."^" G DEVX

 I $L(Y) S DEV(9.01)=Y

DEV1 ; FILE RESULTS

 I '$D(DEV) G DEVX

 S DA=$$VWC^APCDTWC1(AUPNPAT,APCDVSIT) I 'DA G DEVX ; CREATE A NEW V WELL CHILD RECORD IF NECESSARY

 S DIE="^AUPNVWC(",DR="",FNO=0,TOT=0

 F  S FNO=$O(DEV(FNO)) Q:'FNO  D  ; MAKE THE DR STRING

 . I $L(DR) S DR=DR_";"

 . S TOT=TOT+1,@("VAL"_TOT)=DEV(FNO)

 . S DR=DR_FNO_"///^S X=VAL"_TOT

 . Q

 L +^AUPNVWC(DA):1 I  D ^DIE L -^AUPNVWC(DA)

DEVX D ^XBFMK

 Q

 ;

ARR(DFN,TYPE,DOM,ARR) ;EP - GIVEN A PATIENT DFN AND A KB CATEGORY TYPE, BUILD AN ARRAY OF ITEMS

 ; TYPE = KB CATEGORY TYPE (e.g., PT ED, DEVEL, etc.), DOMAIN = WELL CHILD CARE

 N SEX,DAYS,X,Y,Z,%,TOT,DOB,CIEN,KIEN,CAT,ORD,CODE,MOD,START,STOP,STG,TITLE

 S TOT=0 K ARR

 S %=$G(^DPT(+$G(DFN),0)) I '$L(%) Q

 S SEX=$P(%,U,2),DOB=$P(%,U,3) I '$L(SEX)!('DOB) Q

 S DAYS=$$FMDIFF^XLFDT(DT,DOB,1)

 S CAT=0

 F  S CAT=$O(^VEN(7.13,DOM,1,CAT)) Q:'CAT  D  ; CREATE THE ORDINAL ARRAY OF KB CATEGORIES OF THIS TYPE.

 . S CIEN=+$G(^VEN(7.13,DOM,1,CAT,0)) I 'CIEN Q

 . I $P($G(^VEN(7.11,CIEN,0)),U,11)'=TYPE Q  ; TYPE MUST MATCH SELECTION

 . S ORD=$P(^VEN(7.13,DOM,1,CAT,0),U,2)

 . I 'ORD S ORD=100+CAT ; MAKE SURE EVERY CAT HAS AN ORDER - EVEN IF ONE IS NOT OFFICIALLY ASSIGNED

 . S ORD(ORD)=CIEN ; TYPICALLY THE ORD ARRAY WILL ONLY HAVE ONE NODE

 . Q

 ; NOW CHECK ALL ENTRIES IN THE KNOWLEDGE CATEGORY AND BUILD THE DATA ENTRY ARRAY (ARR)

 ; LOOP USING THE ORD ARRAY (ORD)

 S (TOT,ORD)=0

 F  S ORD=$O(ORD(ORD)) Q:'ORD  S CIEN=ORD(ORD) S KIEN=0 F  S KIEN=$O(^VEN(7.12,"B",CIEN,KIEN)) Q:'KIEN  D

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

 . I $P(STG,U,11) Q  ; INACTIVE ITEM !!!

 . S START=$P(STG,U,5) I DAYS<START Q

 . S STOP=$P(STG,U,6) I DAYS>STOP Q

 . S CODE=$P(STG,U,4)

 . S %=$P(STG,U,10) I $L(%),%'=SEX Q

 . S TITLE=$P(STG,U,2) I '$L(TITLE) Q

 . S MOD=$P(STG,U,12)

 . I $L(MOD) S TITLE=TITLE_" ("_MOD_")"

 . S TOT=TOT+1

 . S ARR(TOT)=TOT_". "_TITLE

 . S ARR(TOT,0)=KIEN,ARR("X",KIEN)=TOT

 . I $L(CODE) S ARR("CODE",CODE,TOT)=TITLE

 . Q

 Q

 ; 

RANGE(ARR) ;EP - MANAGE A RANGE OF ARRAY NUMBERS

 N CNT,MAX,DIR,DEL,PCE,A,B,X,MORE,RFLG,%

PRE ; CHECK V FILE TO SEE IF ANYTHING HAS ALREADY BEEN SELECTED

 S MORE=0

R1 S CNT=0,MAX=$O(ARR(999),-1)

 F  S CNT=$O(ARR(CNT)) Q:'CNT  W !,?3,ARR(CNT) I $D(ARR(CNT,1)) W " [SELECTED]"

 I MORE W !,"Want to make any additional changes" S %=2 D YN^DICN I %'=1 G RANGEX

 S DIR(0)="FO^1:7",DIR("A")="Select ITEMS by number"

 S DIR("?")="Sample: 1,2,4-6,-9,-12-15,16"

 D ^DIR

 I $E(Y)'="-",'Y G RANGEX

 S DEL=$L(Y,",")

 F PCE=1:1:DEL D

 . S X=$P(Y,",",PCE),RFLG=0

 . I $E(X)="-" S RFLG=1,X=$E(X,2,99)

 . S A=+X I 'A W !,"The expression '",$P(Y,",",PCE),"' is invalid" Q

 . S B=$P(X,"-",2) I B="" S B=A

 . S B=+B

 . I A>B W !,"The expression '",$P(Y,",",PCE),"' is invalid" Q

 . F X=A:1:B D

 .. I '$D(ARR(X)) W !,"Item number ",X," does not exist" Q

 .. I RFLG,'$D(ARR(X,1)) W !,"Item number ",X," has not been selected - can't remove it" Q

 .. I RFLG K ARR(X,1) Q

 .. I $D(ARR(X,1)) W !,"Item "_X_" has already been selected" Q

 .. S ARR(X,1)=""

 .. Q

 . Q

 S MORE=1  W ! G R1

RANGEX K DIRUT,DIRDT,DUOUT,DIROUT,DTOUT

 S (%,X)=0 F  S X=$O(ARR(X)) Q:'X  I $D(ARR(X,1)) S %=1 Q

 I '% K ARR ; NOTHING SELECTED, SO KILL OFF THE ARRAY

 Q

 ;

NUT ; ENTER NUTRITION TOPICS

 D FEED^APCDTWC1(APCDVSIT) ; INFANT FEEDING PRACTICES

 N ARR,AGIEN,%,X,Y,TOT,LOU,TIME,FTIME,GRP,WVCIEN,TYPE,TITLE,DOM

 S X=$O(^VEN(7.13,"B","WELL CHILD NATL NUTR STDS 9999"),-1) Q:X=""  S Y=$O(^(X,0)) I 'Y Q

 I '$P($G(^VEN(7.13,Y,0)),U,7) W !,"No NUTRITION guidelines available..." Q  ; NUTRITION DOMAIN IS INACIVE

 S TITLE="nutrition counseling ",TYPE=6,DOM=6

 D ARR(AUPNPAT,TYPE,DOM,.ARR) ; BUILD THE PRE-SELECTION ARRAY

 I '$D(ARR) W !!,"No nutrition topics are required for this visit!!",!! H 1 G NUTX

 S VWCIEN=$O(^AUPNVWC("AD",APCDVSIT,999999999),-1)

 I VWCIEN D  ; CHECK FOR EXISTING SELECTIONS AND UPDATE THE ARRAY

 . S TOT=0 F  S TOT=$O(ARR(TOT)) Q:'TOT  D

 .. S X=ARR(TOT)

 .. S X=$P(X,". ",2)

 .. S X=$E(X,1,30)

 .. I $D(^AUPNVWC(VWCIEN,5,"B",X)) S ARR(TOT,1)="" ; IF ITS ALREADY IN V WC, SET THE ARR NODE TO 'SELECTED'

 .. Q

 . Q

 I '$D(ARR) G NUTX

 W !!,"Select from the list of standard ",TITLE,"topics: "

 D RANGE(.ARR) I '$D(ARR) Q  ; GET FINAL SELECTION ARRAY

NUTFILE ; MAKE ENTRIES IN V WC AND V PATIENT ED

 S (LOU,TIME,FTIME)="",GRP="I"

 D LOU^APCDTWC1(TITLE,.LOU,.TIME,.FTIME) ; GET LEVEL OF UNDERSTANDING AND NUT ED TIME

 D NVWCFILE^APCDTWC1(LOU,TIME) ; FILE RESULTS IN V WELL CHILD ; REQUIRES THE SELECTION ARRAY

 D VPEFILE^APCDTWC1(LOU,FTIME,GRP) ; FILE RESULTS IN V PATIENT ED ; REQUIRES THE SELECTION ARRAY

NUTX K ARR ; CLEANUP ARRAY

 Q

 ; 

PTED ; ENTER PATIENT EDUCATION TOPICS

 ; RESULTS ARE FILE IN BOTH V PATIENT ED AND V WELL CHILD AS FREE TEXT SUBTOPICS

 S X=$O(^VEN(7.13,"B","WELL CHILD NATL AG STDS 9999"),-1) Q:X=""  S Y=$O(^(X,0)) I 'Y Q

 I '$P($G(^VEN(7.13,Y,0)),U,7) W !,"No PATIENT EDUCATION guidelines available..." Q  ; AG DOMAIN IS INACIVE

 N ARR,AGIEN,%,X,TOT,LOU,TIME,FTIME,GRP,WVCIEN,TYPE,TITLE,DOM

 S TITLE="patient education ",TYPE=1,DOM=5

 D ARR(AUPNPAT,TYPE,DOM,.ARR) ; BUILD THE PRE-SELECTION ARRAY

 S VWCIEN=$O(^AUPNVWC("AD",APCDVSIT,999999999),-1)

 I VWCIEN D  ; CHECK FOR EXISTING SELECTIONS AND UPDATE THE ARRAY

 . S TOT=0 F  S TOT=$O(ARR(TOT)) Q:'TOT  D

 .. S X=ARR(TOT)

 .. S X=$P(X,". ",2)

 .. S X=$E(X,1,30)

 .. I $D(^AUPNVWC(VWCIEN,1,"B",X)) S ARR(TOT,1)="" ; IF ITS ALREADY IN V WC, SET THE ARR NODE TO 'SELECTED'

 .. Q

 . Q

 I '$D(ARR) Q

 W !!,"Select from the list of standard ",TITLE,"topics: "

 D RANGE(.ARR) I '$D(ARR) Q  ; GET FINAL SELECTION ARRAY

PEFILE ; AT THIS POINT WE HAVE THE FINAL SELECTION ARRAY AND ARE READY TO MAKE ENTRIES IN V WELL CHILD AND V PATIENT ED

 S (LOU,TIME,FTIME)="",GRP="I"

 D LOU^APCDTWC1(TITLE,.LOU,.TIME,.FTIME,.EDU) ; GET LEVEL OF UNDERSTANDING AND PT ED TIME

 D PEWCFILE^APCDTWC1(LOU,TIME,EDU) ; FILE RESULTS IN V WELL CHILD ; REQUIRES THE SELECTION ARRAY

 D VPEFILE^APCDTWC1(LOU,FTIME,GRP) ; FILE RESULTS IN V PATIENT ED ; REQUIRES THE SELECTION ARRAY

 K ARR ; CLEANUP ARRAY

 Q

 ; 

EXAM ; ENTER SPECIAL EXAMS AND SCREENING PROCEDURES

 S X=$O(^VEN(7.13,"B","WELL CHILD NATL EXAM STDS 9999"),-1) Q:X=""  S Y=$O(^(X,0)) I 'Y Q

 I '$P($G(^VEN(7.13,Y,0)),U,7) W !,"No EXAM guidelines available..." Q  ; EXAM DOMAIN IS INACIVE

 D EXAM^APCDTWC2

 Q

 ; 

ASQ ; ENTER ASQ SCORES

 D ASQFILE^APCDTWC1

 Q

 ; 

APCDTWC   ; IHS/CMI/LAB - GENERATED FROM 'APCD WCE (ADD)' INPUT TEMPLATE(#XXX), FILE 9000010 ; 

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ; WELL CHILD EXAM INPUT TEMPLATE FOR PCC AND PCC+

 +3       ; 

 +4       ;

DATA      ; DFN MUST BE DEFINED

           IF '$DATA(^DPT(+$GET(AUPNPAT),0))

               QUIT 

 +1       ; VISIT MUST BE DEFINED

           IF '$GET(^AUPNVSIT(+$GET(APCDVSIT),0))

               QUIT 

 +2        IF $ORDER(^VEN(7.12))

               IF $ORDER(^VEN(7.13))

 +3       IF '$TEST

               Begin DoDot:1

 +4                WRITE !,"Sorry, if you want to use this Mnemonic,"

 +5                WRITE !,"the PCC+ Knowledgebase must be installed."

 +6                WRITE !,"Request cancelled..."

 +7                HANG 1

 +8                QUIT 

               End DoDot:1

               QUIT 

 +9        WRITE !!!,?15,"***  DATA ENTRY - WELL CHILD EXAM  ***"

 +10      ; PREVENT THE "An error has occurred, I think" message.

           KILL Y

NEW        NEW DIR,DIC,DIE,DA,X,Y,%,%T,%,%Y,%DT,VDATE

 +1       ; VISIT DATE MUST EXIST

           SET VDATE=^AUPNVSIT(APCDVSIT,0)\1

           IF 'VDATE

               QUIT 

 +2       ; ONLY SET DEFAULT TO "A" ON THE FIRST PASS

           SET DIR("B")="A"

MENU      ; MAIN DATA ENTRY MENU FOR WELL CHILD CARE VISIT

 +1        SET DIR(0)="S^1:Clinic;2:Provider;3:POV;4:Development/Autism Screen comments;5:Patient education;6:Nutrition;7:Screening exams;8:ASQ score;A:ALL items;Q:QUIT THIS MNEMONIC"

 +2        SET DIR("A")="Your choice"

           DO ^DIR

           KILL DIR

 +3       ; EDIT THE V OB RECORD

           IF Y="A"

               DO ALL

               GOTO MENU

 +4       ; BAIL OUT

           IF '$GET(Y)

               GOTO FIN

 +5        DO @$PIECE("CLN^PRV^POV^DEV^PTED^NUT^EXAM^ASQ",U,Y)

           WRITE !!

           GOTO MENU

FIN        DO ^XBFMK

 +1        QUIT 

 +2       ;

TEST       NEW AUPNPAT,APCDVSIT

           SET AUPNPAT=1

           SET AUPNVSIT=71262

           DO APCDTWC

           QUIT 

 +1       ; 

ALL       ; EDIT ALL SECTIONS

 +1        DO CLN

           DO PRV

           DO POV

           DO DEV

           DO PTED

           DO NUT

           DO EXAM

           DO ASQ

 +2        QUIT 

 +3       ;

CLN       ; EDIT CLINIC

 +1        NEW CIEN,CLN,DA,DIE,DR,%,DIC,X,Y

 +2        SET CIEN=$ORDER(^DIC(40.7,"C",24,0))

           SET CLN=""

 +3        IF 'CIEN

               SET CLN="GENERAL"

 +4        IF CIEN

               SET CLN=$PIECE($GET(^DIC(40.7,CIEN,0)),U)

 +5        SET %=$PIECE($GET(^AUPNVSIT(APCDVSIT,0)),U,8)

           IF %

               SET CLN=$PIECE($GET(^DIC(40.7,%,0)),U)

 +6        SET DIE="^AUPNVSIT("

           SET DA=APCDVSIT

           SET DR=".08//"_CLN

 +7        LOCK +^AUPNVSIT(APCDVSIT):1

          IF $TEST

               DO ^DIE

               LOCK -^AUPNVSIT(APCDVSIT)

 +8        QUIT 

 +9       ;

PRV       ; ENTER THE PROVIDERS

 +1        NEW DIC,DA,DR,DIE,X,Y,%,PS

 +2        SET %=0

           SET X=0

 +3        FOR 

               SET X=$ORDER(^AUPNVPRV("AD",APCDVSIT,X))

               IF 'X

                   QUIT 

               IF $EXTRACT($PIECE($GET(^AUPNVPRV(X,0)),U,4))="P"

                   SET %=1

                   QUIT 

 +4        IF %=1

               WRITE !,"A primary provider has already been entered for this visit..."

               GOTO PRV2

 +5        SET DIC("A")="Provider: "

 +6        SET PS="PRIMARY"

PRVQ       SET DIC=200

           SET DIC(0)="AEQM"

 +1        IF $PIECE($GET(^DD(9000010.06,.01,0)),U,2)[6

               SET DIC=6

 +2        DO ^DIC

           IF Y=-1

               DO ^XBFMK

               QUIT 

 +3        SET %=0

           SET X=0

 +4        FOR 

               SET X=$ORDER(^AUPNVPRV("AD",APCDVSIT,X))

               IF 'X

                   QUIT 

               IF +$GET(^AUPNVPRV(X,0))=+Y

                   SET %=1

                   QUIT 

 +5        IF %=1

               WRITE !,"This provider has already been entered for this visit..."

               GOTO PRV2

PRV1       SET DIC="^AUPNVPRV("

           SET DIC(0)="L"

           SET DLAYGO=9000010.06

           SET X="""`"_+Y_""""

 +1        DO ^DIC

           IF Y=-1

               DO ^XBFMK

               QUIT 

 +2        SET DA=+Y

           SET DIE=DIC

           SET DR=".02////^S X=AUPNPAT;.03////^S X=APCDVSIT;.04//"_PS

 +3        LOCK +^AUPNVPRV(DA):1

          IF $TEST

               DO ^DIE

               LOCK -^AUPNVPRV(DA)

PRV2       SET PS="SECONDARY"

 +1        SET DIC("A")="Another provider: "

 +2       ; GET MORE

           GOTO PRVQ

 +3       ;

POV       ; PURPOSE OF VISIT

 +1        NEW DA

 +2        SET DA=APCDVSIT

 +3       ; THERE IS ALREADY A POV FOR THIS VISIT

           IF $DATA(^AUPNVPOV("AD",DA))

               GOTO POV1

 +4        NEW DIC,DIE,DR,X,Y,%,DIR,NIEN,IIEN

 +5        SET DIC="^AUTNPOV("

           SET DIC(0)="L"

           SET DLAYGO=9999999.27

           SET X="WELL CHILD EXAM"

 +6        DO ^DIC

           IF Y=-1

               GOTO POVX

 +7       ; GET IEN FOR 'WELL CHILD EXAM' PROVIDER NARRATIVE

           SET NIEN=+Y

 +8       ; GET THE ICD9 IEN FOR A WELL CHILD EXAM

           SET X=$ORDER(^ICD9("AB","V20.2",0))

           IF 'X

               SET X=$ORDER(^ICD9("AB","V20.2 ",0))

               IF 'X

                   GOTO POVX

 +9        SET DIC="^AUPNVPOV("

           SET DIC(0)="L"

           SET DLAYGO=9000010.07

           SET X="""`"_X_""""

 +10      ; CREATE NEW POV ENTRY

           DO ^DIC

           IF Y=-1

               GOTO POVX

 +11       SET DA=+Y

           SET DIE=DIC

           SET DR=".02////^S X=AUPNPAT;.03////^S X=APCDVSIT;.04////^S X=NIEN;.12////P"

 +12       LOCK +^AUPNVPOV(DA):1

          IF $TEST

               DO ^DIE

               LOCK -^AUPNVPOV(DA)

POV1       WRITE !!,"***  WELL CHILD EXAM (V20.2) has been automatically added as a POV  ***"

 +1        WRITE !,"Add additional POV's using the PV mnemonic",!

           QUIT 

POVX       WRITE !,"Unable to automatically add WELL CHILD EXAM as a POV!!!"

 +1        QUIT 

 +2       ; 

DEV       ; ENTER DEVELOPMENT ASSESSMENT

 +1        NEW DEV,DA,DIR,DIE,DR,VAL1,VAL2,VAL3,VAL4,FNO,TOT,X,Y,VWCIEN,%,%Y

 +2        SET X=$ORDER(^VEN(7.13,"B","WELL CHILD NATL DEV STDS 9999"),-1)

           IF X=""

               QUIT 

           SET Y=$ORDER(^(X,0))

           IF 'Y

               QUIT 

 +3       ; DEV DOMAIN IS INACIVE

           IF '$PIECE($GET(^VEN(7.13,Y,0)),U,7)

               WRITE !,"No DEV guidelines available..."

               QUIT 

 +4        SET VWCIEN=$ORDER(^AUPNVWC("AD",APCDVSIT,999999999),-1)

 +5        WRITE !!,"Want to enter Development or Autism screen comments"

           SET %=2

 +6        DO YN^DICN

           IF %'=1

               QUIT 

 +7        SET DIR(0)="FO^1:60"

           SET DIR("A")="Fine motor"

 +8        SET DIR("B")="OK"

 +9        IF VWCIEN

               SET %=$PIECE($GET(^AUPNVWC(VWCIEN,3)),U,1)

               IF $LENGTH(%)

                   SET DIR("B")=%

 +10       DO ^DIR

           KILL DIR

           IF Y?1."^"

               GOTO DEVX

 +11       IF $LENGTH(Y)

               SET DEV(3.01)=Y

 +12       SET DIR(0)="FO^1:60"

           SET DIR("A")="Gross motor"

 +13       SET DIR("B")="OK"

 +14       IF VWCIEN

               SET %=$PIECE($GET(^AUPNVWC(VWCIEN,3)),U,2)

               IF $LENGTH(%)

                   SET DIR("B")=%

 +15       DO ^DIR

           KILL DIR

           IF Y?1."^"

               GOTO DEVX

 +16       IF $LENGTH(Y)

               SET DEV(3.02)=Y

 +17       SET DIR(0)="FO^1:60"

           SET DIR("A")="Language"

 +18       SET DIR("B")="OK"

 +19       IF VWCIEN

               SET %=$PIECE($GET(^AUPNVWC(VWCIEN,3)),U,3)

               IF $LENGTH(%)

                   SET DIR("B")=%

 +20       DO ^DIR

           KILL DIR

           IF Y?1."^"

               GOTO DEVX

 +21       IF $LENGTH(Y)

               SET DEV(3.03)=Y

 +22       SET DIR(0)="FO^1:60"

           SET DIR("A")="Social"

 +23       SET DIR("B")="OK"

 +24       IF VWCIEN

               SET %=$PIECE($GET(^AUPNVWC(VWCIEN,3)),U,4)

               IF $LENGTH(%)

                   SET DIR("B")=%

 +25       DO ^DIR

           KILL DIR

           IF Y?1."^"

               GOTO DEVX

 +26       IF $LENGTH(Y)

               SET DEV(3.04)=Y

 +27       SET DIR(0)="FO^1:60"

           SET DIR("A")="Autism screen"

 +28       SET DIR("B")="OK"

 +29       IF VWCIEN

               SET %=$PIECE($GET(^AUPNVWC(VWCIEN,9)),U,1)

               IF $LENGTH(%)

                   SET DIR("B")=%

 +30       DO ^DIR

           KILL DIR

           IF Y?1."^"

               GOTO DEVX

 +31       IF $LENGTH(Y)

               SET DEV(9.01)=Y

DEV1      ; FILE RESULTS

 +1        IF '$DATA(DEV)

               GOTO DEVX

 +2       ; CREATE A NEW V WELL CHILD RECORD IF NECESSARY

           SET DA=$$VWC^APCDTWC1(AUPNPAT,APCDVSIT)

           IF 'DA

               GOTO DEVX

 +3        SET DIE="^AUPNVWC("

           SET DR=""

           SET FNO=0

           SET TOT=0

 +4       ; MAKE THE DR STRING

           FOR 

               SET FNO=$ORDER(DEV(FNO))

               IF 'FNO

                   QUIT 

               Begin DoDot:1

 +5                IF $LENGTH(DR)

                       SET DR=DR_";"

 +6                SET TOT=TOT+1

                   SET @("VAL"_TOT)=DEV(FNO)

 +7                SET DR=DR_FNO_"///^S X=VAL"_TOT

 +8                QUIT 

               End DoDot:1

 +9        LOCK +^AUPNVWC(DA):1

          IF $TEST

               DO ^DIE

               LOCK -^AUPNVWC(DA)

DEVX       DO ^XBFMK

 +1        QUIT 

 +2       ;

ARR(DFN,TYPE,DOM,ARR) ;EP - GIVEN A PATIENT DFN AND A KB CATEGORY TYPE, BUILD AN ARRAY OF ITEMS

 +1       ; TYPE = KB CATEGORY TYPE (e.g., PT ED, DEVEL, etc.), DOMAIN = WELL CHILD CARE

 +2        NEW SEX,DAYS,X,Y,Z,%,TOT,DOB,CIEN,KIEN,CAT,ORD,CODE,MOD,START,STOP,STG,TITLE

 +3        SET TOT=0

           KILL ARR

 +4        SET %=$GET(^DPT(+$GET(DFN),0))

           IF '$LENGTH(%)

               QUIT 

 +5        SET SEX=$PIECE(%,U,2)

           SET DOB=$PIECE(%,U,3)

           IF '$LENGTH(SEX)!('DOB)

               QUIT 

 +6        SET DAYS=$$FMDIFF^XLFDT(DT,DOB,1)

 +7        SET CAT=0

 +8       ; CREATE THE ORDINAL ARRAY OF KB CATEGORIES OF THIS TYPE.

           FOR 

               SET CAT=$ORDER(^VEN(7.13,DOM,1,CAT))

               IF 'CAT

                   QUIT 

               Begin DoDot:1

 +9                SET CIEN=+$GET(^VEN(7.13,DOM,1,CAT,0))

                   IF 'CIEN

                       QUIT 

 +10      ; TYPE MUST MATCH SELECTION

                   IF $PIECE($GET(^VEN(7.11,CIEN,0)),U,11)'=TYPE

                       QUIT 

 +11               SET ORD=$PIECE(^VEN(7.13,DOM,1,CAT,0),U,2)

 +12      ; MAKE SURE EVERY CAT HAS AN ORDER - EVEN IF ONE IS NOT OFFICIALLY ASSIGNED

                   IF 'ORD

                       SET ORD=100+CAT

 +13      ; TYPICALLY THE ORD ARRAY WILL ONLY HAVE ONE NODE

                   SET ORD(ORD)=CIEN

 +14               QUIT 

               End DoDot:1

 +15      ; NOW CHECK ALL ENTRIES IN THE KNOWLEDGE CATEGORY AND BUILD THE DATA ENTRY ARRAY (ARR)

 +16      ; LOOP USING THE ORD ARRAY (ORD)

 +17       SET (TOT,ORD)=0

 +18       FOR 

               SET ORD=$ORDER(ORD(ORD))

               IF 'ORD

                   QUIT 

               SET CIEN=ORD(ORD)

               SET KIEN=0

               FOR 

                   SET KIEN=$ORDER(^VEN(7.12,"B",CIEN,KIEN))

                   IF 'KIEN

                       QUIT 

                   Begin DoDot:1

 +19                   SET STG=$GET(^VEN(7.12,KIEN,0))