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
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"
+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))
IF '$LENGTH(STG)
QUIT
+20 ; INACTIVE ITEM !!!
IF $PIECE(STG,U,11)
QUIT
+21 SET START=$PIECE(STG,U,5)
IF DAYS<START
QUIT
+22 SET STOP=$PIECE(STG,U,6)
IF DAYS>STOP
QUIT
+23 SET CODE=$PIECE(STG,U,4)
+24 SET %=$PIECE(STG,U,10)
IF $LENGTH(%)
IF %'=SEX
QUIT
+25 SET TITLE=$PIECE(STG,U,2)
IF '$LENGTH(TITLE)
QUIT
+26 SET MOD=$PIECE(STG,U,12)
+27 IF $LENGTH(MOD)
SET TITLE=TITLE_" ("_MOD_")"
+28 SET TOT=TOT+1
+29 SET ARR(TOT)=TOT_". "_TITLE
+30 SET ARR(TOT,0)=KIEN
SET ARR("X",KIEN)=TOT
+31 IF $LENGTH(CODE)
SET ARR("CODE",CODE,TOT)=TITLE
+32 QUIT
End DoDot:1
+33 QUIT
+34 ;
RANGE(ARR) ;EP - MANAGE A RANGE OF ARRAY NUMBERS
+1 NEW CNT,MAX,DIR,DEL,PCE,A,B,X,MORE,RFLG,%
PRE ; CHECK V FILE TO SEE IF ANYTHING HAS ALREADY BEEN SELECTED
+1 SET MORE=0
R1 SET CNT=0
SET MAX=$ORDER(ARR(999),-1)
+1 FOR
SET CNT=$ORDER(ARR(CNT))
IF 'CNT
QUIT
WRITE !,?3,ARR(CNT)
IF $DATA(ARR(CNT,1))
WRITE " [SELECTED]"
+2 IF MORE
WRITE !,"Want to make any additional changes"
SET %=2
DO YN^DICN
IF %'=1
GOTO RANGEX
+3 SET DIR(0)="FO^1:7"
SET DIR("A")="Select ITEMS by number"
+4 SET DIR("?")="Sample: 1,2,4-6,-9,-12-15,16"
+5 DO ^DIR
+6 IF $EXTRACT(Y)'="-"
IF 'Y
GOTO RANGEX
+7 SET DEL=$LENGTH(Y,",")
+8 FOR PCE=1:1:DEL
Begin DoDot:1
+9 SET X=$PIECE(Y,",",PCE)
SET RFLG=0
+10 IF $EXTRACT(X)="-"
SET RFLG=1
SET X=$EXTRACT(X,2,99)
+11 SET A=+X
IF 'A
WRITE !,"The expression '",$PIECE(Y,",",PCE),"' is invalid"
QUIT
+12 SET B=$PIECE(X,"-",2)
IF B=""
SET B=A
+13 SET B=+B
+14 IF A>B
WRITE !,"The expression '",$PIECE(Y,",",PCE),"' is invalid"
QUIT
+15 FOR X=A:1:B
Begin DoDot:2
+16 IF '$DATA(ARR(X))
WRITE !,"Item number ",X," does not exist"
QUIT
+17 IF RFLG
IF '$DATA(ARR(X,1))
WRITE !,"Item number ",X," has not been selected - can't remove it"
QUIT
+18 IF RFLG
KILL ARR(X,1)
QUIT
+19 IF $DATA(ARR(X,1))
WRITE !,"Item "_X_" has already been selected"
QUIT
+20 SET ARR(X,1)=""
+21 QUIT
End DoDot:2
+22 QUIT
End DoDot:1
+23 SET MORE=1
WRITE !
GOTO R1
RANGEX KILL DIRUT,DIRDT,DUOUT,DIROUT,DTOUT
+1 SET (%,X)=0
FOR
SET X=$ORDER(ARR(X))
IF 'X
QUIT
IF $DATA(ARR(X,1))
SET %=1
QUIT
+2 ; NOTHING SELECTED, SO KILL OFF THE ARRAY
IF '%
KILL ARR
+3 QUIT
+4 ;
NUT ; ENTER NUTRITION TOPICS
+1 ; INFANT FEEDING PRACTICES
DO FEED^APCDTWC1(APCDVSIT)
+2 NEW ARR,AGIEN,%,X,Y,TOT,LOU,TIME,FTIME,GRP,WVCIEN,TYPE,TITLE,DOM
+3 SET X=$ORDER(^VEN(7.13,"B","WELL CHILD NATL NUTR STDS 9999"),-1)
IF X=""
QUIT
SET Y=$ORDER(^(X,0))
IF 'Y
QUIT
+4 ; NUTRITION DOMAIN IS INACIVE
IF '$PIECE($GET(^VEN(7.13,Y,0)),U,7)
WRITE !,"No NUTRITION guidelines available..."
QUIT
+5 SET TITLE="nutrition counseling "
SET TYPE=6
SET DOM=6
+6 ; BUILD THE PRE-SELECTION ARRAY
DO ARR(AUPNPAT,TYPE,DOM,.ARR)
+7 IF '$DATA(ARR)
WRITE !!,"No nutrition topics are required for this visit!!",!!
HANG 1
GOTO NUTX
+8 SET VWCIEN=$ORDER(^AUPNVWC("AD",APCDVSIT,999999999),-1)
+9 ; CHECK FOR EXISTING SELECTIONS AND UPDATE THE ARRAY
IF VWCIEN
Begin DoDot:1
+10 SET TOT=0
FOR
SET TOT=$ORDER(ARR(TOT))
IF 'TOT
QUIT
Begin DoDot:2
+11 SET X=ARR(TOT)
+12 SET X=$PIECE(X,". ",2)
+13 SET X=$EXTRACT(X,1,30)
+14 ; IF ITS ALREADY IN V WC, SET THE ARR NODE TO 'SELECTED'
IF $DATA(^AUPNVWC(VWCIEN,5,"B",X))
SET ARR(TOT,1)=""
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 IF '$DATA(ARR)
GOTO NUTX
+18 WRITE !!,"Select from the list of standard ",TITLE,"topics: "
+19 ; GET FINAL SELECTION ARRAY
DO RANGE(.ARR)
IF '$DATA(ARR)
QUIT
NUTFILE ; MAKE ENTRIES IN V WC AND V PATIENT ED
+1 SET (LOU,TIME,FTIME)=""
SET GRP="I"
+2 ; GET LEVEL OF UNDERSTANDING AND NUT ED TIME
DO LOU^APCDTWC1(TITLE,.LOU,.TIME,.FTIME)
+3 ; FILE RESULTS IN V WELL CHILD ; REQUIRES THE SELECTION ARRAY
DO NVWCFILE^APCDTWC1(LOU,TIME)
+4 ; FILE RESULTS IN V PATIENT ED ; REQUIRES THE SELECTION ARRAY
DO VPEFILE^APCDTWC1(LOU,FTIME,GRP)
NUTX ; CLEANUP ARRAY
KILL ARR
+1 QUIT
+2 ;
PTED ; ENTER PATIENT EDUCATION TOPICS
+1 ; RESULTS ARE FILE IN BOTH V PATIENT ED AND V WELL CHILD AS FREE TEXT SUBTOPICS
+2 SET X=$ORDER(^VEN(7.13,"B","WELL CHILD NATL AG STDS 9999"),-1)
IF X=""
QUIT
SET Y=$ORDER(^(X,0))
IF 'Y
QUIT
+3 ; AG DOMAIN IS INACIVE
IF '$PIECE($GET(^VEN(7.13,Y,0)),U,7)
WRITE !,"No PATIENT EDUCATION guidelines available..."
QUIT
+4 NEW ARR,AGIEN,%,X,TOT,LOU,TIME,FTIME,GRP,WVCIEN,TYPE,TITLE,DOM
+5 SET TITLE="patient education "
SET TYPE=1
SET DOM=5
+6 ; BUILD THE PRE-SELECTION ARRAY
DO ARR(AUPNPAT,TYPE,DOM,.ARR)
+7 SET VWCIEN=$ORDER(^AUPNVWC("AD",APCDVSIT,999999999),-1)
+8 ; CHECK FOR EXISTING SELECTIONS AND UPDATE THE ARRAY
IF VWCIEN
Begin DoDot:1
+9 SET TOT=0
FOR
SET TOT=$ORDER(ARR(TOT))
IF 'TOT
QUIT
Begin DoDot:2
+10 SET X=ARR(TOT)
+11 SET X=$PIECE(X,". ",2)
+12 SET X=$EXTRACT(X,1,30)
+13 ; IF ITS ALREADY IN V WC, SET THE ARR NODE TO 'SELECTED'
IF $DATA(^AUPNVWC(VWCIEN,1,"B",X))
SET ARR(TOT,1)=""
+14 QUIT
End DoDot:2
+15 QUIT
End DoDot:1
+16 IF '$DATA(ARR)
QUIT
+17 WRITE !!,"Select from the list of standard ",TITLE,"topics: "
+18 ; GET FINAL SELECTION ARRAY
DO RANGE(.ARR)
IF '$DATA(ARR)
QUIT
PEFILE ; AT THIS POINT WE HAVE THE FINAL SELECTION ARRAY AND ARE READY TO MAKE ENTRIES IN V WELL CHILD AND V PATIENT ED
+1 SET (LOU,TIME,FTIME)=""
SET GRP="I"
+2 ; GET LEVEL OF UNDERSTANDING AND PT ED TIME
DO LOU^APCDTWC1(TITLE,.LOU,.TIME,.FTIME,.EDU)
+3 ; FILE RESULTS IN V WELL CHILD ; REQUIRES THE SELECTION ARRAY
DO PEWCFILE^APCDTWC1(LOU,TIME,EDU)
+4 ; FILE RESULTS IN V PATIENT ED ; REQUIRES THE SELECTION ARRAY
DO VPEFILE^APCDTWC1(LOU,FTIME,GRP)
+5 ; CLEANUP ARRAY
KILL ARR
+6 QUIT
+7 ;
EXAM ; ENTER SPECIAL EXAMS AND SCREENING PROCEDURES
+1 SET X=$ORDER(^VEN(7.13,"B","WELL CHILD NATL EXAM STDS 9999"),-1)
IF X=""
QUIT
SET Y=$ORDER(^(X,0))
IF 'Y
QUIT
+2 ; EXAM DOMAIN IS INACIVE
IF '$PIECE($GET(^VEN(7.13,Y,0)),U,7)
WRITE !,"No EXAM guidelines available..."
QUIT
+3 DO EXAM^APCDTWC2
+4 QUIT
+5 ;
ASQ ; ENTER ASQ SCORES
+1 DO ASQFILE^APCDTWC1
+2 QUIT
+3 ;
