APCDTWC2 ; IHS/CMI/LAB - GENERATED FROM 'APCD WCE (ADD)' INPUT TEMPLATE(#XXX), FILE 9000010 01 Aug 2006 5:01 PM ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
; EXAMS
;
;
EXAM ; EP - ENTER SPECIAL EXAMS AND SCREENING PROCEDURES
N ARR,AGIEN,%,X,TOT,LOU,TIME,FTIME,GRP,WVCIEN,TYPE,DOM,TITLE,SS,TITLE,DIR
EQ W !!,"Select EXAM TYPE"
S DIR(0)="S^1:General health screening;2:Age-specific physical exam;3:Special risk screening;4:Behavioral health screening;A:ALL OF ABOVE;Q:QUIT ENTERING EXAMS"
S DIR("A")="Your choice" D ^DIR K DIR
I Y="Q" D ^XBFMK Q ; Q
I Y S Y=$S(Y=1:8,Y=2:4,Y=3:3,1:7) D EX(Y) G EQ ; EDIT A SINGLE EXAM TYPE
S DOM=7
F TYPE=8,4,3,7 D EX(TYPE) ; EDIT ALL 4 EXAM TYPES
G EQ
;
EX(TYPE) ;EP - MANAGE SELECTIONS
I '$G(TYPE) Q
S TITLE=$S(TYPE=4:"age-specific physical exam",TYPE=7:"behavioral health screening exam",TYPE=3:"special risk screening exam",TYPE=8:"general health screening exam",1:"")
I '$L(TITLE) Q
S SS=$S(TYPE=4:6,TYPE=7:7,TYPE=3:4,TYPE=8:8,1:"") I 'SS Q
S DOM=7
D ARR^APCDTWC(AUPNPAT,TYPE,DOM,.ARR) ; BUILD THE PRE-SELECTION ARRAY
I '$D(ARR) W !,"No ",TITLE," items are available for this visit" Q
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,SS,"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 ",TITLE,"(s)"
D RANGE^APCDTWC(.ARR) I '$D(ARR) Q ; GET FINAL SELECTION ARRAY
EFILE ; FILE EXAMS IN V WC AND V EXAM
D EVWCFILE^APCDTWC1(SS) ; FILE RESULTS IN V WELL CHILD ; REQUIRES THE SELECTION ARRAY
K ARR
Q
;
CLEANUP ;EP - CLEANUP
S NAME="Measure",DIK="^VEN(7.12,"
F S NAME=$O(^VEN(7.12,"C",NAME)) Q:NAME'["Measure" S DA=0 F S DA=$O(^VEN(7.12,"C",NAME,DA)) Q:'DA D ^DIK W !,DA
Q
;
ASQAGE(DFN,VDT) ;EP - GIVEN A DFN, RETURN THE ASQ AGE IN MONTHS
; PATCHED BY GIS 1/7/07
N Y1,Y2,M1,M2,D1,D2,YD,MD,M,DOB
;I '$G(DT) Q ""
I '$G(VDT) S VDT=$G(DT) I 'VDT Q ""
S DOB=$$ASQDOB(DFN,VDT)
A1 S Y1=+$E(DOB,1,3),M1=+$E(DOB,4,5),D1=+$E(DOB,6,7)
S Y2=+$E(VDT,1,3),M2=+$E(VDT,4,5),D2=+$E(VDT,6,7)
I M1>M2 S Y2=Y2-1,M2=M2+12
S YD=Y2-Y1,MD=M2-M1
I D2<D1 S MD=MD-1
S M=YD*12+MD
Q M
;
DOBAGE(DFN,VDT) ; GIVEN A DFN, RETURN THE DOB AGE IN MONTHS
; PATCHED BY GIS 1/7/07
N Y1,Y2,M1,M2,D1,D2,YD,MD,M,DOB
I '$G(VDT) S VDT=$G(DT) I 'VDT Q ""
S DOB=$P($G(^DPT(+$G(DFN),0)),U,3)
I '$G(DOB) Q ""
G A1
;
ASQDOB(DFN,VDT) ; EP - GIVEN A DFN, RETURN THE ADJUSTED (ASQ) DOB
; PATCHED BY GIS 1/7/07
N DOB,GA,%
I '$G(VDT) S VDT=$G(DT) I 'VDT Q ""
S DOB=$P($G(^DPT(+$G(DFN),0)),U,3)
I '$G(DOB) Q ""
I $$DOBAGE(DFN,VDT)>24 G A2 ; NO CORRECTIONS FOR PREMIES AFTER CHRONLOGICAL AGE OF 24 MOS!
S GA=$P($G(^AUPNBMSR(DFN,0)),U,6)
I GA,GA<40 S %=(40-GA)*7 I % S DOB=$$FMADD^XLFDT(DOB,-%)
A2 I VDT<DOB Q ""
Q DOB
;
ASQIEN(M) ; EP - GIVEN THE ASQ AGE IN MONTHS, RETURN THE CURRENT ASQ FORM IEN^IEN OF THE NEXT FORM
N IEN,X,Y,IEN2
I +$G(M)<3 Q ""
I M>61 Q ""
S IEN2=""
S IEN=$O(^AUTTASQ("B",M,0))
I IEN S Y=$O(^AUTTASQ("B",M)) S:Y IEN2=$O(^AUTTASQ("B",Y,0)) Q IEN_U_IEN2
S X=M-1,IEN=$O(^AUTTASQ("B",X,0))
I IEN S Y=$O(^AUTTASQ("B",X)) S:Y IEN2=$O(^AUTTASQ("B",Y,0)) Q IEN_U_IEN2
S X=M+1,IEN=$O(^AUTTASQ("B",X,0))
I IEN S Y=$O(^AUTTASQ("B",X)) S:Y IEN2=$O(^AUTTASQ("B",Y,0)) Q IEN_U_IEN2
S X=$O(^AUTTASQ("B",M),-1),IEN=$O(^AUTTASQ("B",X,0))
I IEN S Y=$O(^AUTTASQ("B",M)) S:Y IEN2=$O(^AUTTASQ("B",Y,0)) Q IEN_U_IEN2
Q ""
;
APCDTWC2 ; IHS/CMI/LAB - GENERATED FROM 'APCD WCE (ADD)' INPUT TEMPLATE(#XXX), FILE 9000010 01 Aug 2006 5:01 PM ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ; EXAMS
+3 ;
+4 ;
EXAM ; EP - ENTER SPECIAL EXAMS AND SCREENING PROCEDURES
+1 NEW ARR,AGIEN,%,X,TOT,LOU,TIME,FTIME,GRP,WVCIEN,TYPE,DOM,TITLE,SS,TITLE,DIR
EQ WRITE !!,"Select EXAM TYPE"
+1 SET DIR(0)="S^1:General health screening;2:Age-specific physical exam;3:Special risk screening;4:Behavioral health screening;A:ALL OF ABOVE;Q:QUIT ENTERING EXAMS"
+2 SET DIR("A")="Your choice"
DO ^DIR
KILL DIR
+3 ; Q
IF Y="Q"
DO ^XBFMK
QUIT
+4 ; EDIT A SINGLE EXAM TYPE
IF Y
SET Y=$SELECT(Y=1:8,Y=2:4,Y=3:3,1:7)
DO EX(Y)
GOTO EQ
+5 SET DOM=7
+6 ; EDIT ALL 4 EXAM TYPES
FOR TYPE=8,4,3,7
DO EX(TYPE)
+7 GOTO EQ
+8 ;
EX(TYPE) ;EP - MANAGE SELECTIONS
+1 IF '$GET(TYPE)
QUIT
+2 SET TITLE=$SELECT(TYPE=4:"age-specific physical exam",TYPE=7:"behavioral health screening exam",TYPE=3:"special risk screening exam",TYPE=8:"general health screening exam",1:"")
+3 IF '$LENGTH(TITLE)
QUIT
+4 SET SS=$SELECT(TYPE=4:6,TYPE=7:7,TYPE=3:4,TYPE=8:8,1:"")
IF 'SS
QUIT
+5 SET DOM=7
+6 ; BUILD THE PRE-SELECTION ARRAY
DO ARR^APCDTWC(AUPNPAT,TYPE,DOM,.ARR)
+7 IF '$DATA(ARR)
WRITE !,"No ",TITLE," items are available for this visit"
QUIT
+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,SS,"B",X))
SET ARR(TOT,1)=""
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 IF '$DATA(ARR)
QUIT
+18 WRITE !!,"Select ",TITLE,"(s)"
+19 ; GET FINAL SELECTION ARRAY
DO RANGE^APCDTWC(.ARR)
IF '$DATA(ARR)
QUIT
EFILE ; FILE EXAMS IN V WC AND V EXAM
+1 ; FILE RESULTS IN V WELL CHILD ; REQUIRES THE SELECTION ARRAY
DO EVWCFILE^APCDTWC1(SS)
+2 KILL ARR
+3 QUIT
+4 ;
CLEANUP ;EP - CLEANUP
+1 SET NAME="Measure"
SET DIK="^VEN(7.12,"
+2 FOR
SET NAME=$ORDER(^VEN(7.12,"C",NAME))
IF NAME'["Measure"
QUIT
SET DA=0
FOR
SET DA=$ORDER(^VEN(7.12,"C",NAME,DA))
IF 'DA
QUIT
DO ^DIK
WRITE !,DA
+3 QUIT
+4 ;
ASQAGE(DFN,VDT) ;EP - GIVEN A DFN, RETURN THE ASQ AGE IN MONTHS
+1 ; PATCHED BY GIS 1/7/07
+2 NEW Y1,Y2,M1,M2,D1,D2,YD,MD,M,DOB
+3 ;I '$G(DT) Q ""
+4 IF '$GET(VDT)
SET VDT=$GET(DT)
IF 'VDT
QUIT ""
+5 SET DOB=$$ASQDOB(DFN,VDT)
A1 SET Y1=+$EXTRACT(DOB,1,3)
SET M1=+$EXTRACT(DOB,4,5)
SET D1=+$EXTRACT(DOB,6,7)
+1 SET Y2=+$EXTRACT(VDT,1,3)
SET M2=+$EXTRACT(VDT,4,5)
SET D2=+$EXTRACT(VDT,6,7)
+2 IF M1>M2
SET Y2=Y2-1
SET M2=M2+12
+3 SET YD=Y2-Y1
SET MD=M2-M1
+4 IF D2<D1
SET MD=MD-1
+5 SET M=YD*12+MD
+6 QUIT M
+7 ;
DOBAGE(DFN,VDT) ; GIVEN A DFN, RETURN THE DOB AGE IN MONTHS
+1 ; PATCHED BY GIS 1/7/07
+2 NEW Y1,Y2,M1,M2,D1,D2,YD,MD,M,DOB
+3 IF '$GET(VDT)
SET VDT=$GET(DT)
IF 'VDT
QUIT ""
+4 SET DOB=$PIECE($GET(^DPT(+$GET(DFN),0)),U,3)
+5 IF '$GET(DOB)
QUIT ""
+6 GOTO A1
+7 ;
ASQDOB(DFN,VDT) ; EP - GIVEN A DFN, RETURN THE ADJUSTED (ASQ) DOB
+1 ; PATCHED BY GIS 1/7/07
+2 NEW DOB,GA,%
+3 IF '$GET(VDT)
SET VDT=$GET(DT)
IF 'VDT
QUIT ""
+4 SET DOB=$PIECE($GET(^DPT(+$GET(DFN),0)),U,3)
+5 IF '$GET(DOB)
QUIT ""
+6 ; NO CORRECTIONS FOR PREMIES AFTER CHRONLOGICAL AGE OF 24 MOS!
IF $$DOBAGE(DFN,VDT)>24
GOTO A2
+7 SET GA=$PIECE($GET(^AUPNBMSR(DFN,0)),U,6)
+8 IF GA
IF GA<40
SET %=(40-GA)*7
IF %
SET DOB=$$FMADD^XLFDT(DOB,-%)
A2 IF VDT<DOB
QUIT ""
+1 QUIT DOB
+2 ;
ASQIEN(M) ; EP - GIVEN THE ASQ AGE IN MONTHS, RETURN THE CURRENT ASQ FORM IEN^IEN OF THE NEXT FORM
+1 NEW IEN,X,Y,IEN2
+2 IF +$GET(M)<3
QUIT ""
+3 IF M>61
QUIT ""
+4 SET IEN2=""
+5 SET IEN=$ORDER(^AUTTASQ("B",M,0))
+6 IF IEN
SET Y=$ORDER(^AUTTASQ("B",M))
IF Y
SET IEN2=$ORDER(^AUTTASQ("B",Y,0))
QUIT IEN_U_IEN2
+7 SET X=M-1
SET IEN=$ORDER(^AUTTASQ("B",X,0))
+8 IF IEN
SET Y=$ORDER(^AUTTASQ("B",X))
IF Y
SET IEN2=$ORDER(^AUTTASQ("B",Y,0))
QUIT IEN_U_IEN2
+9 SET X=M+1
SET IEN=$ORDER(^AUTTASQ("B",X,0))
+10 IF IEN
SET Y=$ORDER(^AUTTASQ("B",X))
IF Y
SET IEN2=$ORDER(^AUTTASQ("B",Y,0))
QUIT IEN_U_IEN2
+11 SET X=$ORDER(^AUTTASQ("B",M),-1)
SET IEN=$ORDER(^AUTTASQ("B",X,0))
+12 IF IEN
SET Y=$ORDER(^AUTTASQ("B",M))
IF Y
SET IEN2=$ORDER(^AUTTASQ("B",Y,0))
QUIT IEN_U_IEN2
+13 QUIT ""
+14 ;
