APCDTWC1 ; IHS/CMI/LAB - CONTINUATION OF APCDTWC ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
; WELL CHILD EXAM INPUT TEMPLATE FOR PCC AND PCC+
;
;
VWC(DFN,VIEN) ;EP - RETURN THE V WELL CHILD IEN - CREATE A NEW ONE IF NECESSARY
I '$G(DFN)!('$G(VIEN)) Q ""
N DIC,DIE,DR,DA,X,Y
S DA=$O(^AUPNVWC("AD",VIEN,999999999),-1) I DA Q DA ; A RECORD HAS ALREADY BEEN CREATED - GET LATEST V WC RECORD
S DIC="^AUPNVWC(",DIC(0)="L",DLAYGO=9000010.46,X=""""_0_""""
D ^DIC
I Y=-1 W:'$G(SILENT) !,"Unable to create a new V WELL CHILD record! Results not entered..." Q ""
S DA=+Y,DIE=DIC,DR=".02////^S X=DFN;.03////^S X=VIEN"
L +^AUPNVWC(DA):1 I D ^DIE L -^AUPNVWC(DA)
Q DA
;
EVWCFILE(SS,GUIFLAG) ;EP - FILE EXAMS IN V WC
N DIC,DA,DIE,DR,X,Y,%,TOT,LIEN,CODE,CNT,VWCIEN,PEIEN,VPEIEN,CIEN,CODE,RES
I '$D(ARR) Q
I '$G(SS) Q
S Y=$$VWC(AUPNPAT,APCDVSIT) ; GET V WELL CHILD IEN
I (+Y)<1 G EX ; FAILED TO OBTAIN A V WC IEN
S VWCIEN=+Y K ^AUPNVWC(VWCIEN,SS) ; CLEAN SLATE FOR EXAMS
E1 ; V WC SUBFILE ENTRY
S DA(1)=VWCIEN,DIC="^AUPNVWC("_DA(1)_","_SS_",",DLAYGO=9000010.46_SS,DIC(0)="L"
S DIC("P")=$P(^DD(9000010.46,SS,0),U,2)
S DIE=DIC,DR=".02Exam result (N or A)"
S CNT=0 F S CNT=$O(ARR(CNT)) Q:'CNT I $D(ARR(CNT,1)) D
. S %=$G(ARR(CNT)) I '$L(%) Q ; ENTER SUB-TOPIC NAME AS FREE TEXT
. I %[". " S %=$P(%,". ",2)
. S X=% D ^DIC I Y=-1 Q
. S DA=+Y
. I $G(GUIFLAG) S RES=$G(ARR(CNT,1)) Q:RES="" S DR=".02///^S X=RES" ; SILENT MODE FOR GUI
. E W !,X
. L +^VEN(7.12,DA(1),SS,DA):1 I D ^DIE L -^VEN(7.12,DA(1),SS,DA)
. I '$G(GUIFLAG) W !
. Q
EX D ^XBFMK
Q
;
ASQFILE ;EP - RECORD ASQ RESULTS IN V WELL CHILD AND THEN REDUNDANTLY FILE THEM IN V MEASUREMENT
N DIE,DA,DR,X,Y,ASQM,QIEN,%,STG,DIR,VWCIEN,ASK,PCE,RES
S (DA,VWCIEN)=$$VWC(AUPNPAT,APCDVSIT) I DA<1 G ASQX ; FIND AN EXISTING VISIT OR MAKE A NEW ONE
S ASQM=$$ASQM(APCDVSIT) I 'ASQM W !!,"No ASQ scores should be entered on this visit!!",!! H 1 Q
S DIE="^AUPNVWC(",DR="2.07//^S X=ASQM"
L +^AUPNVWC(DA):1 I D ^DIE L -^AUPNVWC(DA) ; RECORD THE QUESTIONNAIRE
S QIEN=$P($G(^AUPNVWC(DA,2)),U,7)
I 'QIEN W !,"You must specify which form is used before entering results!" G ASQX
S STG=$G(^VEN(7.14,QIEN,0)) I '$L(STG) Q
S ASK="COMMUNICATIONS^GROSS MOTOR^FINE MOTOR^PROBLEM SOLVING^PERSONAL-SOCIAL"
F PCE=1:1:5 D ASKASQ(PCE) ; RECORD/FILE THE 5 ASQ SCORES FOR THE QUESTIONNAIRE IN V WELL CHILD
S RES=$G(^AUPNVWC(VWCIEN,2)) I '$P(RES,U,7) G ASQX
F PCE=7,1:1:5 D ASQVMSR(PCE) ; AUTOMATICALLY FILE THE 5 ASQ SCORES FOR THE QUESTIONNAIRE IN V MEASUREMENTS
ASQX D ^XBFMK
Q
;
ASKASQ(PCE) ;EP - GET AQS SCORE AND FILE IT
N DIR,DIE,DIC,DA,DR,X,Y,%,ASQX,FLD
S FLD=$E(32154,PCE) ; PUT ELEMENTS IN CORRECT ORDER
ASK1 S DIR(0)="NO^0:100:"
S DIR("A")=$P(ASK,U,PCE)_" score"
S %=$P($G(^AUPNVWC(VWCIEN,2)),U,FLD) I $L(%) S DIR("B")=+%
D ^DIR KILL DIR
I 'Y Q
I Y#5 W " ??",!,"A valid score must be a multipe of 5 (0,5,10,15...)" G ASK1
S ASQX=Y_" ("_$P(STG,U,PCE+1)_")"
ASK2 S DA=VWCIEN,DIE="^AUPNVWC(",DR="2.0"_FLD_"///^S X=ASQX"
L +^AUPNVWC(DA):1 I D ^DIE L -^AUPNVWC(DA)
Q
;
ASQVMSR(PCE) ; FILE ASQ SCORES IN V MEASUREMNTS
N DIE,DIC,DA,DR,X,Y,VAL
S X=$P("ASQF^ASQG^ASQL^ASQS^ASQP^^ASQM",U,PCE) I X="" Q
S DA=$$VMSR(APCDVSIT,X) I 'DA Q ; FIND EXISTING V MEASUREMENT OR MAKE A NEW ONE
S VAL=$P(RES,U,PCE) I '$L(VAL) Q
I PCE=7 S VAL=+$G(^VEN(7.14,+VAL,0)) I 'VAL Q
S DIE="^AUPNVMSR(",DR=".04////^S X=VAL"
I $P($G(^AUPNVMSR(DA,0)),U,2)="" S DR=".02////^S X=AUPNPAT;.03////^S X=APCDVSIT;"_DR
L +^AUPNVMSR(DA):1 I D ^DIE L -^AUPNVMSR(DA)
Q
;
VMSR(VIEN,TYPE) ;EP - FIND OR CREATE A V MEASUREMENT ENTRY
N MIEN,VMIEN,DIC,X,Y
S MIEN=$O(^AUTTMSR("B",TYPE,0)) I 'MIEN Q "" ; GET THE MEASUREMENT IEN
S VMIEN=0
F S VMIEN=$O(^AUPNVMSR("AD",VIEN,VMIEN)) Q:'VMIEN I +$G(^AUPNVMSR(VMIEN,0))=MIEN Q
I VMIEN Q VMIEN ; A V MEAS ENTRY ALREADY EXISTS FOR THIS ASQ CATEGORY AND VISIT
S DIC="^AUPNVMSR(",DIC(0)="L",DLAYGO=9000010.01
S X=""""_TYPE_""""
D ^DIC I Y=-1 Q "" ; MAKE A NEW V MEAS ENTRY
Q +Y
;
ASQM(VIEN) ; RETURN THE ASQ QUESTIONNAIRE (MOS)
N M,VDT,ASQM,DFN,IEN
S VDT=+$G(^AUPNVSIT(+$G(VIEN),0))\1 I 'VDT Q "" ; PATCHED BY GIS 1/7/07 TO MEET SAC GUIDELINES
S DFN=$P(^AUPNVSIT(VIEN,0),U,5) I 'DFN Q ""
S M=$$ASQAGE^APCDTWC2(DFN,VDT) I 'M Q ""
S IEN=+$$ASQIEN^APCDTWC2(M) I 'IEN Q ""
S ASQM=+$G(^VEN(7.14,IEN,0)) I 'ASQM Q ""
Q ASQM
;
FEED(VIEN) ;EP - INFANT FEEDING PRACTICES
N DIC,DIE,DA,DR,X,Y,Z,%,AGE,DFN,DOB,DIR,FIEN,SEL
S DFN=$P($G(^AUPNVSIT(+$G(VIEN),0)),U,5) I 'DFN Q
S DOB=$P($G(^DPT(DFN,0)),U,3) I 'DOB Q
S AGE=(DT=DOB)\10000
S FIEN=$O(^AUPNVIF("AD",VIEN,0))
I 'FIEN,AGE>1 Q ; ONLY APPLIES TO INFANTS
I 'FIEN W !,"Was an Infant Feeding Choice recorded" S %=2 D YN^DICN I %'=1 Q
I FIEN S DIR("B")=$P($G(^AUPNVIF(FIEN,0)),U)
S DIR(0)="SO^1:EXCLUSIVE BREASTFEEDING;2:MOSTLY BREASTFEEDING;3:1/2 & 1/2 BREAST AND FORMULA;4:MOSTLY FORMULA;5:FORMULA ONLY;6:NOT SPECIFIED"
S DIR("A")="Feeding choice"
D ^DIR K DIR,DA
S SEL=Y
I SEL=6,'FIEN Q
I 'SEL D ^XBFMK Q
I FIEN S DA=FIEN,DIK="^AUPNVIF(" D ^DIK K DIK,DA I SEL=6 Q ; CLEAN SLATE
S DIC="^AUPNVIF(",DIC(0)="L",DLAYGO=9000010.44,X=""""_SEL_""""
FEED1 D ^DIC I Y=-1 Q
S DIE=DIC,DA=+Y,DR=".02////^S X=DFN;.03////^S X=VIEN"
L +^AUPNVIF(DA):1 I D ^DIE L -^AUPNVIF(DA)
D ^XBFMK
Q
;
EXFILE ;EP - MAKE V EXAM ENTRIES
; NEED NEW EXAM TYPE: 'WELL CHILD SCREENING' - DONE
; NEED MULTIPLE UNDER V EXAM FOR SPECIFIC EXAMS - DONE
N DIC,DIE,DA,DR,X,Y,%,CODE,TOT,CIEN,VIEN
EXVCLEAN ; CLEAN OUT ALL V EXAM ENTRIES ASSOCIATED WITH THIS VISIT AND THE EXAM LIST
S DIK="^AUPNVXAM(" S DA=0
F S DA=$O(^AUPNVXAM("AD",APCDVSIT,DA)) Q:'DA D
. S CIEN=+$G(^AUPNVXAM(DA,0)) I 'CIEN Q
. S CODE=$P($G(^AUTTEXAM(CIEN,0)),U,2)
. S TOT=0
. F S TOT=$O(ARR("CODE",CODE,TOT)) Q:'TOT I $D(ARR(TOT,1)) D ^DIK
. Q
EXVADD ; MAKE NEW V FILE ENTRY
S DIC="^AUPNVXAM(",DIC(0)="L",DLAYGO=9000010.13
S CODE="" F S CODE=$O(ARR("CODE",CODE)) Q:CODE="" D
. S CIEN=$O(^AUTTEXAM("C",CODE,0)) I 'CIEN Q
. S X="`"_CIEN
. D ^DIC I Y=-1 Q
. S DIE=DIC,DA=+Y,DR=".02////^S X=DFN;.03////^S X=APCDVSIT"
. L +^AUPNVXAM(DA):1 I D ^DIE L -^AUPNVXAM(DA)
. S DA(1)=DA,DIC="^AUPNVXAM("_DA(1)_",1,",DIC(0)="L",DLAYGO=900010.131
. S TOT=0 F S TOT=$O(ARR("CODE",CODE,TOT)) Q:'TOT D
.. S X=$G(ARR("CODE",CODE,TOT)) D ^DIC
.. Q
. Q
D ^XBFMK
Q
;
NVWCFILE(LOU,TIME,EDU) ;EP - MAKE V WC NUTR ENTRIES
N DIC,DA,DIE,DR,X,Y,%,TOT,LIEN,CODE,CNT,VWCIEN,PEIEN,VPEIEN,CIEN,CODE
I '$D(ARR) Q
S Y=$$VWC(AUPNPAT,APCDVSIT) ; GET V WELL CHILD IEN
I (+Y)<1 G FX ; FAILED TO OBTAIN A V WC IEN
S VWCIEN=+Y K ^AUPNVWC(VWCIEN,5) ; CLEAN SLATE FOR NUTR TOPICS
N1 ; NUTR COUNSELING FIELDS
S LOU=$G(LOU),TIME=$G(TIME),EDU=$G(EDU)
S DIE="^AUPNVWC(",DA=VWCIEN,DR=""
I $L($G(LOU)) S DR=".08///^S X=LOU"
I $G(TIME) S:$L(DR) DR=DR_";" S DR=DR_".07///^S X=TIME"
I $G(EDU) S:$L(DR) DR=DR_";" S DR=DR_".09////^S X=EDU"
L +^AUPNVWC(DA):1 I D ^DIE L -^AUPNVWC(DA)
N2 ; V WC NURT SUBFILE ENTRY
S DA(1)=VWCIEN,DIC="^AUPNVWC("_DA(1)_",5,",DLAYGO=9000010.465,DIC(0)="L"
S DIC("P")=$P(^DD(9000010.46,5,0),U,2)
S CNT=0 F S CNT=$O(ARR(CNT)) Q:'CNT I $D(ARR(CNT,1)) D
. S %=$G(ARR(CNT)) I '$L(%) Q ; ENTER SUB-TOPIC NAME AS FREE TEXT
. I %[". " S %=$P(%,". ",2)
. S X=% D ^DIC
. Q
NX D ^XBFMK
Q
;
PEWCFILE(LOU,TIME,EDU) ;EP - MAKE V WELL CHILD ENTRIES
N DIC,DA,DIE,DR,X,Y,%,TOT,LIEN,CODE,CNT,VWCIEN,PEIEN,VPEIEN,CIEN,CODE
I '$D(ARR) Q
S Y=$$VWC(AUPNPAT,APCDVSIT) I 'Y Q ; GET V WELL CHILD IEN
S VWCIEN=+Y
D CLEANVWC(VWCIEN) ; CLEAN SLATE FOR PT ED TOPICS!
F1 ; PT ED FIELDS ; VALUES APPLY TO ENTIRE SESSION - NOT JUST A SINGLE TOPIC
S DIE="^AUPNVWC(",DA=VWCIEN
S DR=""
I $L($G(LOU)) S DR=".06///^S X=LOU"
I $G(TIME) S:$L(DR) DR=DR_";" S DR=DR_".05///^S X=TIME"
I $G(EDU) S:$L(DR) DR=DR_";" S DR=DR_".04////^S X=EDU"
I $L(DR) L +^AUPNVWC(DA):1 I D ^DIE L -^AUPNVWC(DA)
F2 ; V WELL CHILD PT ED SUBFILE ENTRY
S DA(1)=VWCIEN,DIC="^AUPNVWC("_DA(1)_",1,",DLAYGO=9000010.461,DIC(0)="L"
S DIC("P")=$P(^DD(9000010.46,1,0),U,2)
S CNT=0 F S CNT=$O(ARR(CNT)) Q:'CNT I $D(ARR(CNT,1)) D
. S %=$G(ARR(CNT)) I '$L(%) Q ; ENTER SUB-TOPIC NAME AS FREE TEXT
. I %[". " S %=$P(%,". ",2)
. S X=% D ^DIC
. Q
FX D ^XBFMK
Q
;
CLEANVWC(VWCIEN) ;EP - CLEANUP PREVIOUS ENTRIES
N X,Y,%,SEL,DIK,DA,CNT
S DA=0,DA(1)=VWCIEN
S DIK="^AUPNVWC("_DA(1)_",1,"
F S DA=$O(^AUPNVWC(VWCIEN,1,DA)) Q:'DA D
. S X=$G(^AUPNVWC(VWCIEN,1,DA,0)) I '$L(X) Q
. S CNT=0
. F S CNT=$O(ARR(CNT)) Q:'CNT D
.. S Y=$G(ARR(CNT)) I Y'=X Q
CLN .. D ^DIK ; THIS SUBFILE ENTRY MATCHES ONE OF THIS TYPE'S POSSIBLE CHOICES, SO CLEAR IT OUT
.. Q
. Q
D ^XBFMK
Q
;
VPEFILE(LOU,FTIME,EDU) ;EP - MAKE V PATIENT ED ENTRIES
N DIC,DIE,DA,DR,X,Y,%,DIK,CIEN,CODE,SEL,TOT,CAT,T,ITEM,VPEIEN,GRP
I '$D(ARR("CODE")) Q
UVAR ; USER VARIEBLES
S LOU=$G(LOU) S LOU=$$UP^XLFSTR(LOU) ; LEVEL OF UNDERSTANDING
S FTIME=$G(FTIME) ; FRACTIONAL EDUCATION TIME (AVERAGED ACROSS ALL TOPICS) - POS INTEGER
I FTIME=+FTIME,FTIME=FTIME\1,FTIME>-1
E S FTIME=""
S GRP="I" ; COUNSELLING TYPE: INDIVIDUAL
S EDU=$G(EDU) I '$D(^VA(200,EDU,0)) S EDU="" ; EDUCATOR IEN
VPECLEAN ; CLEAN SLATE FOR ALL TOPICS IN THE LIST
S DA=0,DIK="^AUPNVPED("
F S DA=$O(^AUPNVPED("AD",APCDVSIT,DA)) Q:'DA D
. S CIEN=+$G(^AUPNVPED(DA,0)) I 'CIEN Q
. S CODE=$P($G(^AUTTEDT(CIEN,0)),U,2) I '$L(CODE) Q
. I $D(ARR("CODE",CODE)) D ^DIK ; THIS ENTRY'S CODE IS IN THE ARRAY, SO KLILL IT OFF
. Q
VPEADD ; ADD PATIENT ED ENTRIES IN V PATIENT ED - ONE FOR EACH PT ED CODE WITH SUB-TOPICS IN THE '1' MULTIPLE
S CODE=""
F S CODE=$O(ARR("CODE",CODE)) Q:CODE="" D ; SORT BY CODE GROUP
. S SEL=0,TOT=0,DIC="^AUPNVPED(",DIC(0)="L",DLAYGO=9000010.16
. F S TOT=$O(ARR("CODE",CODE,TOT)) Q:'TOT I $D(ARR(TOT,1)) S SEL=1 Q
. I 'SEL Q ; STOP IF NO ITEMS WITH THIS CODE WERE SELECTED
. S CIEN=$$CODE(CODE) I 'CIEN Q ; GET THE CORRECT CODE IEN
. S X="""`"_CIEN_"""" ; THE .01 FIELD OF V PATIENT ED POINT TO THE EDUCATION TOPICS FILE
. D ^DIC I Y=-1 Q
. S (VPEIEN,DA)=+Y,DIE="^AUPNVPED("
. S DR=".02////^S X=AUPNPAT;.03////^S X=APCDVSIT;.06///^S X=LOU;.07///^S X=GRP;.08///^S X=FTIME"
. L +^AUPNVPED(DA):1 I D ^DIE L -^AUPNVPED(DA)
. K DA
. S TOT=0,DA(1)=VPEIEN,DIC="^AUPNVPED("_DA(1)_",1,",DIC(0)="L",DLAYGO=9000010.161
. S DIC("P")=$P(^DD(9000010.16,1,0),U,2)
. F S TOT=$O(ARR("CODE",CODE,TOT)) Q:'TOT D ; ENTER SUB TOPICS
.. I '$D(ARR(TOT,1)) Q ; TOPIC MUST BE SELECTED
.. S X=$G(ARR("CODE",CODE,TOT)) I '$L(X) Q
.. S X=$TR(X,$C(34),"") ; STRIP OFF QUOTES
.. D ^DIC
.. Q
. Q
D ^XBFMK
Q
;
CODE(CODE) ;EP - RETURN THE IEN OF THE MOST RECENT VALID/ACTIVE INSTANCE OF A PT ED CODE
N OK,CIEN,%
S OK=0,CIEN=999999
F S CIEN=$O(^AUTTEDT("C",CODE,CIEN),-1) Q:'CIEN D I OK=1 Q ; FIND MOST RECENT VALID INSTANCE OF CODE
. S %=$G(^AUTTEDT(CIEN,0)) I '$L(%) Q
. I '$P(%,U,3) S OK=1 ; MUST HAVE A VALID CODE
. Q
Q CIEN
;
LOU(TITLE,LOU,TIME,FTIME,EDU) ;EP - GET LEVEL OF UNDERSTANDING, TOTAL PT ED TIME AND FRACTIONAL PT ED TIME, EDUCATOR
N DIR,X,Y,CNT,CODE,TOT,VWCIEN,LL,LT,DIC
S (LL,LT)=""
S VWCIEN=+$O(^AUPNVWC("AD",APCDVSIT,999999999),-1)
S %=$G(^AUPNVWC(VWCIEN,0))
I TITLE["nutrition" S LL=$P(%,U,8),LT=$P(%,U,7)
E S LL=$P(%,U,6),LT=$P(%,U,5)
S DIC=200,DIC(0)="AEQM",DIC("A")="Name of educator: ",DIC("B")=$P($G(^AUPNVWC(VWCIEN,0)),U,4),EDU=""
D ^DIC I +Y>0 S EDU=+Y
W !!,"If possible, record the level of understanding and duration of ",TITLE,"session"
S DIR(0)="SO^1:POOR;2:FAIR;3:GOOD;5:REFUSED"
S DIR("A")="Level of understanding" I LL S DIR("B")=LL
D ^DIR K DIR I 'Y G TIME
S LOU=Y
TIME S DIR(0)="NO^1:100:0"
S DIR("A")="Total "_TITLE_"time (min)" I LT S DIR("B")=LT
D ^DIR K DIR
I 'Y D ^XBFMK Q
S TIME=Y,CNT=0,CODE=""
F S CODE=$O(ARR("CODE",CODE)) Q:CODE="" D
. S TOT=0
. F S TOT=$O(ARR("CODE",CODE,TOT)) Q:'TOT I $D(ARR(TOT,1)) S CNT=CNT+1 Q ; IF CODE SELECTED, INC CNT
. Q
I CNT S FTIME=TIME\CNT ; ARBITRARILY DIVIDE TOTAL TIME BY THE NUMBER OF V PATIENT ED ENTRIES FOR THIS VISIT
I '$G(FTIME) S FTIME=1 ; IF FTIME <1 MIN ROUND UP TO 1 MIN
D ^XBFMK
Q
;
APCDTWC1 ; IHS/CMI/LAB - CONTINUATION OF APCDTWC ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ; WELL CHILD EXAM INPUT TEMPLATE FOR PCC AND PCC+
+3 ;
+4 ;
VWC(DFN,VIEN) ;EP - RETURN THE V WELL CHILD IEN - CREATE A NEW ONE IF NECESSARY
+1 IF '$GET(DFN)!('$GET(VIEN))
QUIT ""
+2 NEW DIC,DIE,DR,DA,X,Y
+3 ; A RECORD HAS ALREADY BEEN CREATED - GET LATEST V WC RECORD
SET DA=$ORDER(^AUPNVWC("AD",VIEN,999999999),-1)
IF DA
QUIT DA
+4 SET DIC="^AUPNVWC("
SET DIC(0)="L"
SET DLAYGO=9000010.46
SET X=""""_0_""""
+5 DO ^DIC
+6 IF Y=-1
IF '$GET(SILENT)
WRITE !,"Unable to create a new V WELL CHILD record! Results not entered..."
QUIT ""
+7 SET DA=+Y
SET DIE=DIC
SET DR=".02////^S X=DFN;.03////^S X=VIEN"
+8 LOCK +^AUPNVWC(DA):1
IF $TEST
DO ^DIE
LOCK -^AUPNVWC(DA)
+9 QUIT DA
+10 ;
EVWCFILE(SS,GUIFLAG) ;EP - FILE EXAMS IN V WC
+1 NEW DIC,DA,DIE,DR,X,Y,%,TOT,LIEN,CODE,CNT,VWCIEN,PEIEN,VPEIEN,CIEN,CODE,RES
+2 IF '$DATA(ARR)
QUIT
+3 IF '$GET(SS)
QUIT
+4 ; GET V WELL CHILD IEN
SET Y=$$VWC(AUPNPAT,APCDVSIT)
+5 ; FAILED TO OBTAIN A V WC IEN
IF (+Y)<1
GOTO EX
+6 ; CLEAN SLATE FOR EXAMS
SET VWCIEN=+Y
KILL ^AUPNVWC(VWCIEN,SS)
E1 ; V WC SUBFILE ENTRY
+1 SET DA(1)=VWCIEN
SET DIC="^AUPNVWC("_DA(1)_","_SS_","
SET DLAYGO=9000010.46_SS
SET DIC(0)="L"
+2 SET DIC("P")=$PIECE(^DD(9000010.46,SS,0),U,2)
+3 SET DIE=DIC
SET DR=".02Exam result (N or A)"
+4 SET CNT=0
FOR
SET CNT=$ORDER(ARR(CNT))
IF 'CNT
QUIT
IF $DATA(ARR(CNT,1))
Begin DoDot:1
+5 ; ENTER SUB-TOPIC NAME AS FREE TEXT
SET %=$GET(ARR(CNT))
IF '$LENGTH(%)
QUIT
+6 IF %[". "
SET %=$PIECE(%,". ",2)
+7 SET X=%
DO ^DIC
IF Y=-1
QUIT
+8 SET DA=+Y
+9 ; SILENT MODE FOR GUI
IF $GET(GUIFLAG)
SET RES=$GET(ARR(CNT,1))
IF RES=""
QUIT
SET DR=".02///^S X=RES"
+10 IF '$TEST
WRITE !,X
+11 LOCK +^VEN(7.12,DA(1),SS,DA):1
IF $TEST
DO ^DIE
LOCK -^VEN(7.12,DA(1),SS,DA)
+12 IF '$GET(GUIFLAG)
WRITE !
+13 QUIT
End DoDot:1
EX DO ^XBFMK
+1 QUIT
+2 ;
ASQFILE ;EP - RECORD ASQ RESULTS IN V WELL CHILD AND THEN REDUNDANTLY FILE THEM IN V MEASUREMENT
+1 NEW DIE,DA,DR,X,Y,ASQM,QIEN,%,STG,DIR,VWCIEN,ASK,PCE,RES
+2 ; FIND AN EXISTING VISIT OR MAKE A NEW ONE
SET (DA,VWCIEN)=$$VWC(AUPNPAT,APCDVSIT)
IF DA<1
GOTO ASQX
+3 SET ASQM=$$ASQM(APCDVSIT)
IF 'ASQM
WRITE !!,"No ASQ scores should be entered on this visit!!",!!
HANG 1
QUIT
+4 SET DIE="^AUPNVWC("
SET DR="2.07//^S X=ASQM"
+5 ; RECORD THE QUESTIONNAIRE
LOCK +^AUPNVWC(DA):1
IF $TEST
DO ^DIE
LOCK -^AUPNVWC(DA)
+6 SET QIEN=$PIECE($GET(^AUPNVWC(DA,2)),U,7)
+7 IF 'QIEN
WRITE !,"You must specify which form is used before entering results!"
GOTO ASQX
+8 SET STG=$GET(^VEN(7.14,QIEN,0))
IF '$LENGTH(STG)
QUIT
+9 SET ASK="COMMUNICATIONS^GROSS MOTOR^FINE MOTOR^PROBLEM SOLVING^PERSONAL-SOCIAL"
+10 ; RECORD/FILE THE 5 ASQ SCORES FOR THE QUESTIONNAIRE IN V WELL CHILD
FOR PCE=1:1:5
DO ASKASQ(PCE)
+11 SET RES=$GET(^AUPNVWC(VWCIEN,2))
IF '$PIECE(RES,U,7)
GOTO ASQX
+12 ; AUTOMATICALLY FILE THE 5 ASQ SCORES FOR THE QUESTIONNAIRE IN V MEASUREMENTS
FOR PCE=7,1:1:5
DO ASQVMSR(PCE)
ASQX DO ^XBFMK
+1 QUIT
+2 ;
ASKASQ(PCE) ;EP - GET AQS SCORE AND FILE IT
+1 NEW DIR,DIE,DIC,DA,DR,X,Y,%,ASQX,FLD
+2 ; PUT ELEMENTS IN CORRECT ORDER
SET FLD=$EXTRACT(32154,PCE)
ASK1 SET DIR(0)="NO^0:100:"
+1 SET DIR("A")=$PIECE(ASK,U,PCE)_" score"
+2 SET %=$PIECE($GET(^AUPNVWC(VWCIEN,2)),U,FLD)
IF $LENGTH(%)
SET DIR("B")=+%
+3 DO ^DIR
KILL DIR
+4 IF 'Y
QUIT
+5 IF Y#5
WRITE " ??",!,"A valid score must be a multipe of 5 (0,5,10,15...)"
GOTO ASK1
+6 SET ASQX=Y_" ("_$PIECE(STG,U,PCE+1)_")"
ASK2 SET DA=VWCIEN
SET DIE="^AUPNVWC("
SET DR="2.0"_FLD_"///^S X=ASQX"
+1 LOCK +^AUPNVWC(DA):1
IF $TEST
DO ^DIE
LOCK -^AUPNVWC(DA)
+2 QUIT
+3 ;
ASQVMSR(PCE) ; FILE ASQ SCORES IN V MEASUREMNTS
+1 NEW DIE,DIC,DA,DR,X,Y,VAL
+2 SET X=$PIECE("ASQF^ASQG^ASQL^ASQS^ASQP^^ASQM",U,PCE)
IF X=""
QUIT
+3 ; FIND EXISTING V MEASUREMENT OR MAKE A NEW ONE
SET DA=$$VMSR(APCDVSIT,X)
IF 'DA
QUIT
+4 SET VAL=$PIECE(RES,U,PCE)
IF '$LENGTH(VAL)
QUIT
+5 IF PCE=7
SET VAL=+$GET(^VEN(7.14,+VAL,0))
IF 'VAL
QUIT
+6 SET DIE="^AUPNVMSR("
SET DR=".04////^S X=VAL"
+7 IF $PIECE($GET(^AUPNVMSR(DA,0)),U,2)=""
SET DR=".02////^S X=AUPNPAT;.03////^S X=APCDVSIT;"_DR
+8 LOCK +^AUPNVMSR(DA):1
IF $TEST
DO ^DIE
LOCK -^AUPNVMSR(DA)
+9 QUIT
+10 ;
VMSR(VIEN,TYPE) ;EP - FIND OR CREATE A V MEASUREMENT ENTRY
+1 NEW MIEN,VMIEN,DIC,X,Y
+2 ; GET THE MEASUREMENT IEN
SET MIEN=$ORDER(^AUTTMSR("B",TYPE,0))
IF 'MIEN
QUIT ""
+3 SET VMIEN=0
+4 FOR
SET VMIEN=$ORDER(^AUPNVMSR("AD",VIEN,VMIEN))
IF 'VMIEN
QUIT
IF +$GET(^AUPNVMSR(VMIEN,0))=MIEN
QUIT
+5 ; A V MEAS ENTRY ALREADY EXISTS FOR THIS ASQ CATEGORY AND VISIT
IF VMIEN
QUIT VMIEN
+6 SET DIC="^AUPNVMSR("
SET DIC(0)="L"
SET DLAYGO=9000010.01
+7 SET X=""""_TYPE_""""
+8 ; MAKE A NEW V MEAS ENTRY
DO ^DIC
IF Y=-1
QUIT ""
+9 QUIT +Y
+10 ;
ASQM(VIEN) ; RETURN THE ASQ QUESTIONNAIRE (MOS)
+1 NEW M,VDT,ASQM,DFN,IEN
+2 ; PATCHED BY GIS 1/7/07 TO MEET SAC GUIDELINES
SET VDT=+$GET(^AUPNVSIT(+$GET(VIEN),0))\1
IF 'VDT
QUIT ""
+3 SET DFN=$PIECE(^AUPNVSIT(VIEN,0),U,5)
IF 'DFN
QUIT ""
+4 SET M=$$ASQAGE^APCDTWC2(DFN,VDT)
IF 'M
QUIT ""
+5 SET IEN=+$$ASQIEN^APCDTWC2(M)
IF 'IEN
QUIT ""
+6 SET ASQM=+$GET(^VEN(7.14,IEN,0))
IF 'ASQM
QUIT ""
+7 QUIT ASQM
+8 ;
FEED(VIEN) ;EP - INFANT FEEDING PRACTICES
+1 NEW DIC,DIE,DA,DR,X,Y,Z,%,AGE,DFN,DOB,DIR,FIEN,SEL
+2 SET DFN=$PIECE($GET(^AUPNVSIT(+$GET(VIEN),0)),U,5)
IF 'DFN
QUIT
+3 SET DOB=$PIECE($GET(^DPT(DFN,0)),U,3)
IF 'DOB
QUIT
+4 SET AGE=(DT=DOB)\10000
+5 SET FIEN=$ORDER(^AUPNVIF("AD",VIEN,0))
+6 ; ONLY APPLIES TO INFANTS
IF 'FIEN
IF AGE>1
QUIT
+7 IF 'FIEN
WRITE !,"Was an Infant Feeding Choice recorded"
SET %=2
DO YN^DICN
IF %'=1
QUIT
+8 IF FIEN
SET DIR("B")=$PIECE($GET(^AUPNVIF(FIEN,0)),U)
+9 SET DIR(0)="SO^1:EXCLUSIVE BREASTFEEDING;2:MOSTLY BREASTFEEDING;3:1/2 & 1/2 BREAST AND FORMULA;4:MOSTLY FORMULA;5:FORMULA ONLY;6:NOT SPECIFIED"
+10 SET DIR("A")="Feeding choice"
+11 DO ^DIR
KILL DIR,DA
+12 SET SEL=Y
+13 IF SEL=6
IF 'FIEN
QUIT
+14 IF 'SEL
DO ^XBFMK
QUIT
+15 ; CLEAN SLATE
IF FIEN
SET DA=FIEN
SET DIK="^AUPNVIF("
DO ^DIK
KILL DIK,DA
IF SEL=6
QUIT
+16 SET DIC="^AUPNVIF("
SET DIC(0)="L"
SET DLAYGO=9000010.44
SET X=""""_SEL_""""
FEED1 DO ^DIC
IF Y=-1
QUIT
+1 SET DIE=DIC
SET DA=+Y
SET DR=".02////^S X=DFN;.03////^S X=VIEN"
+2 LOCK +^AUPNVIF(DA):1
IF $TEST
DO ^DIE
LOCK -^AUPNVIF(DA)
+3 DO ^XBFMK
+4 QUIT
+5 ;
EXFILE ;EP - MAKE V EXAM ENTRIES
+1 ; NEED NEW EXAM TYPE: 'WELL CHILD SCREENING' - DONE
+2 ; NEED MULTIPLE UNDER V EXAM FOR SPECIFIC EXAMS - DONE
+3 NEW DIC,DIE,DA,DR,X,Y,%,CODE,TOT,CIEN,VIEN
EXVCLEAN ; CLEAN OUT ALL V EXAM ENTRIES ASSOCIATED WITH THIS VISIT AND THE EXAM LIST
+1 SET DIK="^AUPNVXAM("
SET DA=0
+2 FOR
SET DA=$ORDER(^AUPNVXAM("AD",APCDVSIT,DA))
IF 'DA
QUIT
Begin DoDot:1
+3 SET CIEN=+$GET(^AUPNVXAM(DA,0))
IF 'CIEN
QUIT
+4 SET CODE=$PIECE($GET(^AUTTEXAM(CIEN,0)),U,2)
+5 SET TOT=0
+6 FOR
SET TOT=$ORDER(ARR("CODE",CODE,TOT))
IF 'TOT
QUIT
IF $DATA(ARR(TOT,1))
DO ^DIK
+7 QUIT
End DoDot:1
EXVADD ; MAKE NEW V FILE ENTRY
+1 SET DIC="^AUPNVXAM("
SET DIC(0)="L"
SET DLAYGO=9000010.13
+2 SET CODE=""
FOR
SET CODE=$ORDER(ARR("CODE",CODE))
IF CODE=""
QUIT
Begin DoDot:1
+3 SET CIEN=$ORDER(^AUTTEXAM("C",CODE,0))
IF 'CIEN
QUIT
+4 SET X="`"_CIEN
+5 DO ^DIC
IF Y=-1
QUIT
+6 SET DIE=DIC
SET DA=+Y
SET DR=".02////^S X=DFN;.03////^S X=APCDVSIT"
+7 LOCK +^AUPNVXAM(DA):1
IF $TEST
DO ^DIE
LOCK -^AUPNVXAM(DA)
+8 SET DA(1)=DA
SET DIC="^AUPNVXAM("_DA(1)_",1,"
SET DIC(0)="L"
SET DLAYGO=900010.131
+9 SET TOT=0
FOR
SET TOT=$ORDER(ARR("CODE",CODE,TOT))
IF 'TOT
QUIT
Begin DoDot:2
+10 SET X=$GET(ARR("CODE",CODE,TOT))
DO ^DIC
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 DO ^XBFMK
+14 QUIT
+15 ;
NVWCFILE(LOU,TIME,EDU) ;EP - MAKE V WC NUTR ENTRIES
+1 NEW DIC,DA,DIE,DR,X,Y,%,TOT,LIEN,CODE,CNT,VWCIEN,PEIEN,VPEIEN,CIEN,CODE
+2 IF '$DATA(ARR)
QUIT
+3 ; GET V WELL CHILD IEN
SET Y=$$VWC(AUPNPAT,APCDVSIT)
+4 ; FAILED TO OBTAIN A V WC IEN
IF (+Y)<1
GOTO FX
+5 ; CLEAN SLATE FOR NUTR TOPICS
SET VWCIEN=+Y
KILL ^AUPNVWC(VWCIEN,5)
N1 ; NUTR COUNSELING FIELDS
+1 SET LOU=$GET(LOU)
SET TIME=$GET(TIME)
SET EDU=$GET(EDU)
+2 SET DIE="^AUPNVWC("
SET DA=VWCIEN
SET DR=""
+3 IF $LENGTH($GET(LOU))
SET DR=".08///^S X=LOU"
+4 IF $GET(TIME)
IF $LENGTH(DR)
SET DR=DR_";"
SET DR=DR_".07///^S X=TIME"
+5 IF $GET(EDU)
IF $LENGTH(DR)
SET DR=DR_";"
SET DR=DR_".09////^S X=EDU"
+6 LOCK +^AUPNVWC(DA):1
IF $TEST
DO ^DIE
LOCK -^AUPNVWC(DA)
N2 ; V WC NURT SUBFILE ENTRY
+1 SET DA(1)=VWCIEN
SET DIC="^AUPNVWC("_DA(1)_",5,"
SET DLAYGO=9000010.465
SET DIC(0)="L"
+2 SET DIC("P")=$PIECE(^DD(9000010.46,5,0),U,2)
+3 SET CNT=0
FOR
SET CNT=$ORDER(ARR(CNT))
IF 'CNT
QUIT
IF $DATA(ARR(CNT,1))
Begin DoDot:1
+4 ; ENTER SUB-TOPIC NAME AS FREE TEXT
SET %=$GET(ARR(CNT))
IF '$LENGTH(%)
QUIT
+5 IF %[". "
SET %=$PIECE(%,". ",2)
+6 SET X=%
DO ^DIC
+7 QUIT
End DoDot:1
NX DO ^XBFMK
+1 QUIT
+2 ;
PEWCFILE(LOU,TIME,EDU) ;EP - MAKE V WELL CHILD ENTRIES
+1 NEW DIC,DA,DIE,DR,X,Y,%,TOT,LIEN,CODE,CNT,VWCIEN,PEIEN,VPEIEN,CIEN,CODE
+2 IF '$DATA(ARR)
QUIT
+3 ; GET V WELL CHILD IEN
SET Y=$$VWC(AUPNPAT,APCDVSIT)
IF 'Y
QUIT
+4 SET VWCIEN=+Y
+5 ; CLEAN SLATE FOR PT ED TOPICS!
DO CLEANVWC(VWCIEN)
F1 ; PT ED FIELDS ; VALUES APPLY TO ENTIRE SESSION - NOT JUST A SINGLE TOPIC
+1 SET DIE="^AUPNVWC("
SET DA=VWCIEN
+2 SET DR=""
+3 IF $LENGTH($GET(LOU))
SET DR=".06///^S X=LOU"
+4 IF $GET(TIME)
IF $LENGTH(DR)
SET DR=DR_";"
SET DR=DR_".05///^S X=TIME"
+5 IF $GET(EDU)
IF $LENGTH(DR)
SET DR=DR_";"
SET DR=DR_".04////^S X=EDU"
+6 IF $LENGTH(DR)
LOCK +^AUPNVWC(DA):1
IF $TEST
DO ^DIE
LOCK -^AUPNVWC(DA)
F2 ; V WELL CHILD PT ED SUBFILE ENTRY
+1 SET DA(1)=VWCIEN
SET DIC="^AUPNVWC("_DA(1)_",1,"
SET DLAYGO=9000010.461
SET DIC(0)="L"
+2 SET DIC("P")=$PIECE(^DD(9000010.46,1,0),U,2)
+3 SET CNT=0
FOR
SET CNT=$ORDER(ARR(CNT))
IF 'CNT
QUIT
IF $DATA(ARR(CNT,1))
Begin DoDot:1
+4 ; ENTER SUB-TOPIC NAME AS FREE TEXT
SET %=$GET(ARR(CNT))
IF '$LENGTH(%)
QUIT
+5 IF %[". "
SET %=$PIECE(%,". ",2)
+6 SET X=%
DO ^DIC
+7 QUIT
End DoDot:1
FX DO ^XBFMK
+1 QUIT
+2 ;
CLEANVWC(VWCIEN) ;EP - CLEANUP PREVIOUS ENTRIES
+1 NEW X,Y,%,SEL,DIK,DA,CNT
+2 SET DA=0
SET DA(1)=VWCIEN
+3 SET DIK="^AUPNVWC("_DA(1)_",1,"
+4 FOR
SET DA=$ORDER(^AUPNVWC(VWCIEN,1,DA))
IF 'DA
QUIT
Begin DoDot:1
+5 SET X=$GET(^AUPNVWC(VWCIEN,1,DA,0))
IF '$LENGTH(X)
QUIT
+6 SET CNT=0
+7 FOR
SET CNT=$ORDER(ARR(CNT))
IF 'CNT
QUIT
Begin DoDot:2
+8 SET Y=$GET(ARR(CNT))
IF Y'=X
QUIT
CLN ; THIS SUBFILE ENTRY MATCHES ONE OF THIS TYPE'S POSSIBLE CHOICES, SO CLEAR IT OUT
DO ^DIK
+1 QUIT
End DoDot:2
+2 QUIT
End DoDot:1
+3 DO ^XBFMK
+4 QUIT
+5 ;
VPEFILE(LOU,FTIME,EDU) ;EP - MAKE V PATIENT ED ENTRIES
+1 NEW DIC,DIE,DA,DR,X,Y,%,DIK,CIEN,CODE,SEL,TOT,CAT,T,ITEM,VPEIEN,GRP
+2 IF '$DATA(ARR("CODE"))
QUIT
UVAR ; USER VARIEBLES
+1 ; LEVEL OF UNDERSTANDING
SET LOU=$GET(LOU)
SET LOU=$$UP^XLFSTR(LOU)
+2 ; FRACTIONAL EDUCATION TIME (AVERAGED ACROSS ALL TOPICS) - POS INTEGER
SET FTIME=$GET(FTIME)
+3 IF FTIME=+FTIME
IF FTIME=FTIME\1
IF FTIME>-1
+4 IF '$TEST
SET FTIME=""
+5 ; COUNSELLING TYPE: INDIVIDUAL
SET GRP="I"
+6 ; EDUCATOR IEN
SET EDU=$GET(EDU)
IF '$DATA(^VA(200,EDU,0))
SET EDU=""
VPECLEAN ; CLEAN SLATE FOR ALL TOPICS IN THE LIST
+1 SET DA=0
SET DIK="^AUPNVPED("
+2 FOR
SET DA=$ORDER(^AUPNVPED("AD",APCDVSIT,DA))
IF 'DA
QUIT
Begin DoDot:1
+3 SET CIEN=+$GET(^AUPNVPED(DA,0))
IF 'CIEN
QUIT
+4 SET CODE=$PIECE($GET(^AUTTEDT(CIEN,0)),U,2)
IF '$LENGTH(CODE)
QUIT
+5 ; THIS ENTRY'S CODE IS IN THE ARRAY, SO KLILL IT OFF
IF $DATA(ARR("CODE",CODE))
DO ^DIK
+6 QUIT
End DoDot:1
VPEADD ; ADD PATIENT ED ENTRIES IN V PATIENT ED - ONE FOR EACH PT ED CODE WITH SUB-TOPICS IN THE '1' MULTIPLE
+1 SET CODE=""
+2 ; SORT BY CODE GROUP
FOR
SET CODE=$ORDER(ARR("CODE",CODE))
IF CODE=""
QUIT
Begin DoDot:1
+3 SET SEL=0
SET TOT=0
SET DIC="^AUPNVPED("
SET DIC(0)="L"
SET DLAYGO=9000010.16
+4 FOR
SET TOT=$ORDER(ARR("CODE",CODE,TOT))
IF 'TOT
QUIT
IF $DATA(ARR(TOT,1))
SET SEL=1
QUIT
+5 ; STOP IF NO ITEMS WITH THIS CODE WERE SELECTED
IF 'SEL
QUIT
+6 ; GET THE CORRECT CODE IEN
SET CIEN=$$CODE(CODE)
IF 'CIEN
QUIT
+7 ; THE .01 FIELD OF V PATIENT ED POINT TO THE EDUCATION TOPICS FILE
SET X="""`"_CIEN_""""
+8 DO ^DIC
IF Y=-1
QUIT
+9 SET (VPEIEN,DA)=+Y
SET DIE="^AUPNVPED("
+10 SET DR=".02////^S X=AUPNPAT;.03////^S X=APCDVSIT;.06///^S X=LOU;.07///^S X=GRP;.08///^S X=FTIME"
+11 LOCK +^AUPNVPED(DA):1
IF $TEST
DO ^DIE
LOCK -^AUPNVPED(DA)
+12 KILL DA
+13 SET TOT=0
SET DA(1)=VPEIEN
SET DIC="^AUPNVPED("_DA(1)_",1,"
SET DIC(0)="L"
SET DLAYGO=9000010.161
+14 SET DIC("P")=$PIECE(^DD(9000010.16,1,0),U,2)
+15 ; ENTER SUB TOPICS
FOR
SET TOT=$ORDER(ARR("CODE",CODE,TOT))
IF 'TOT
QUIT
Begin DoDot:2
+16 ; TOPIC MUST BE SELECTED
IF '$DATA(ARR(TOT,1))
QUIT
+17 SET X=$GET(ARR("CODE",CODE,TOT))
IF '$LENGTH(X)
QUIT
+18 ; STRIP OFF QUOTES
SET X=$TRANSLATE(X,$CHAR(34),"")
+19 DO ^DIC
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
+22 DO ^XBFMK
+23 QUIT
+24 ;
CODE(CODE) ;EP - RETURN THE IEN OF THE MOST RECENT VALID/ACTIVE INSTANCE OF A PT ED CODE
+1 NEW OK,CIEN,%
+2 SET OK=0
SET CIEN=999999
+3 ; FIND MOST RECENT VALID INSTANCE OF CODE
FOR
SET CIEN=$ORDER(^AUTTEDT("C",CODE,CIEN),-1)
IF 'CIEN
QUIT
Begin DoDot:1
+4 SET %=$GET(^AUTTEDT(CIEN,0))
IF '$LENGTH(%)
QUIT
+5 ; MUST HAVE A VALID CODE
IF '$PIECE(%,U,3)
SET OK=1
+6 QUIT
End DoDot:1
IF OK=1
QUIT
+7 QUIT CIEN
+8 ;
LOU(TITLE,LOU,TIME,FTIME,EDU) ;EP - GET LEVEL OF UNDERSTANDING, TOTAL PT ED TIME AND FRACTIONAL PT ED TIME, EDUCATOR
+1 NEW DIR,X,Y,CNT,CODE,TOT,VWCIEN,LL,LT,DIC
+2 SET (LL,LT)=""
+3 SET VWCIEN=+$ORDER(^AUPNVWC("AD",APCDVSIT,999999999),-1)
+4 SET %=$GET(^AUPNVWC(VWCIEN,0))
+5 IF TITLE["nutrition"
SET LL=$PIECE(%,U,8)
SET LT=$PIECE(%,U,7)
+6 IF '$TEST
SET LL=$PIECE(%,U,6)
SET LT=$PIECE(%,U,5)
+7 SET DIC=200
SET DIC(0)="AEQM"
SET DIC("A")="Name of educator: "
SET DIC("B")=$PIECE($GET(^AUPNVWC(VWCIEN,0)),U,4)
SET EDU=""
+8 DO ^DIC
IF +Y>0
SET EDU=+Y
+9 WRITE !!,"If possible, record the level of understanding and duration of ",TITLE,"session"
+10 SET DIR(0)="SO^1:POOR;2:FAIR;3:GOOD;5:REFUSED"
+11 SET DIR("A")="Level of understanding"
IF LL
SET DIR("B")=LL
+12 DO ^DIR
KILL DIR
IF 'Y
GOTO TIME
+13 SET LOU=Y
TIME SET DIR(0)="NO^1:100:0"
+1 SET DIR("A")="Total "_TITLE_"time (min)"
IF LT
SET DIR("B")=LT
+2 DO ^DIR
KILL DIR
+3 IF 'Y
DO ^XBFMK
QUIT
+4 SET TIME=Y
SET CNT=0
SET CODE=""
+5 FOR
SET CODE=$ORDER(ARR("CODE",CODE))
IF CODE=""
QUIT
Begin DoDot:1
+6 SET TOT=0
+7 ; IF CODE SELECTED, INC CNT
FOR
SET TOT=$ORDER(ARR("CODE",CODE,TOT))
IF 'TOT
QUIT
IF $DATA(ARR(TOT,1))
SET CNT=CNT+1
QUIT
+8 QUIT
End DoDot:1
+9 ; ARBITRARILY DIVIDE TOTAL TIME BY THE NUMBER OF V PATIENT ED ENTRIES FOR THIS VISIT
IF CNT
SET FTIME=TIME\CNT
+10 ; IF FTIME <1 MIN ROUND UP TO 1 MIN
IF '$GET(FTIME)
SET FTIME=1
+11 DO ^XBFMK
+12 QUIT
+13 ;
