Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCDTWC2

APCDTWC2.m

Go to the documentation of this file. 
  1. 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
  1.  ; EXAMS
  1.  ; 
  1.  ;
  1. EXAM ; EP -  ENTER SPECIAL EXAMS AND SCREENING PROCEDURES
  1.  N ARR,AGIEN,%,X,TOT,LOU,TIME,FTIME,GRP,WVCIEN,TYPE,DOM,TITLE,SS,TITLE,DIR
  1. EQ W !!,"Select EXAM TYPE"
  1.  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"
  1.  S DIR("A")="Your choice" D ^DIR K DIR
  1.  I Y="Q" D ^XBFMK Q  ; Q
  1.  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
  1.  S DOM=7
  1.  F TYPE=8,4,3,7 D EX(TYPE) ; EDIT ALL 4 EXAM TYPES
  1.  G EQ
  1.  ; 
  1. EX(TYPE) ;EP - MANAGE SELECTIONS
  1.  I '$G(TYPE) Q
  1.  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:"")
  1.  I '$L(TITLE) Q
  1.  S SS=$S(TYPE=4:6,TYPE=7:7,TYPE=3:4,TYPE=8:8,1:"") I 'SS Q
  1.  S DOM=7
  1.  D ARR^APCDTWC(AUPNPAT,TYPE,DOM,.ARR) ; BUILD THE PRE-SELECTION ARRAY
  1.  I '$D(ARR) W !,"No ",TITLE," items are available for this visit" Q
  1.  S VWCIEN=$O(^AUPNVWC("AD",APCDVSIT,999999999),-1)
  1.  I VWCIEN D  ; CHECK FOR EXISTING SELECTIONS AND UPDATE THE ARRAY
  1.  . S TOT=0 F  S TOT=$O(ARR(TOT)) Q:'TOT  D
  1.  .. S X=ARR(TOT)
  1.  .. S X=$P(X,". ",2)
  1.  .. S X=$E(X,1,30)
  1.  .. I $D(^AUPNVWC(VWCIEN,SS,"B",X)) S ARR(TOT,1)="" ; IF ITS ALREADY IN V WC, SET THE ARR NODE TO 'SELECTED'
  1.  .. Q
  1.  . Q
  1.  I '$D(ARR) Q
  1.  W !!,"Select ",TITLE,"(s)"
  1.  D RANGE^APCDTWC(.ARR) I '$D(ARR) Q  ; GET FINAL SELECTION ARRAY
  1. EFILE ; FILE EXAMS IN V WC AND V EXAM
  1.  D EVWCFILE^APCDTWC1(SS) ; FILE RESULTS IN V WELL CHILD ; REQUIRES THE SELECTION ARRAY
  1.  K ARR
  1.  Q
  1.  ; 
  1. CLEANUP ;EP - CLEANUP
  1.  S NAME="Measure",DIK="^VEN(7.12,"
  1.  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
  1.  Q
  1.  ; 
  1. ASQAGE(DFN,VDT) ;EP - GIVEN A DFN, RETURN THE ASQ AGE IN MONTHS
  1.  ; PATCHED BY GIS 1/7/07
  1.  N Y1,Y2,M1,M2,D1,D2,YD,MD,M,DOB
  1.  ;I '$G(DT) Q ""
  1.  I '$G(VDT) S VDT=$G(DT) I 'VDT Q ""
  1.  S DOB=$$ASQDOB(DFN,VDT)
  1. A1 S Y1=+$E(DOB,1,3),M1=+$E(DOB,4,5),D1=+$E(DOB,6,7)
  1.  S Y2=+$E(VDT,1,3),M2=+$E(VDT,4,5),D2=+$E(VDT,6,7)
  1.  I M1>M2 S Y2=Y2-1,M2=M2+12
  1.  S YD=Y2-Y1,MD=M2-M1
  1.  I D2<D1 S MD=MD-1
  1.  S M=YD*12+MD
  1.  Q M
  1.  ; 
  1. DOBAGE(DFN,VDT) ; GIVEN A DFN, RETURN THE DOB AGE IN MONTHS
  1.  ; PATCHED BY GIS 1/7/07
  1.  N Y1,Y2,M1,M2,D1,D2,YD,MD,M,DOB
  1.  I '$G(VDT) S VDT=$G(DT) I 'VDT Q ""
  1.  S DOB=$P($G(^DPT(+$G(DFN),0)),U,3)
  1.  I '$G(DOB) Q ""
  1.  G A1
  1.  ; 
  1. ASQDOB(DFN,VDT) ; EP - GIVEN A DFN, RETURN THE ADJUSTED (ASQ) DOB
  1.  ; PATCHED BY GIS 1/7/07
  1.  N DOB,GA,%
  1.  I '$G(VDT) S VDT=$G(DT) I 'VDT Q ""
  1.  S DOB=$P($G(^DPT(+$G(DFN),0)),U,3)
  1.  I '$G(DOB) Q ""
  1.  I $$DOBAGE(DFN,VDT)>24 G A2 ; NO CORRECTIONS FOR PREMIES AFTER CHRONLOGICAL AGE OF 24 MOS!
  1.  S GA=$P($G(^AUPNBMSR(DFN,0)),U,6)
  1.  I GA,GA<40 S %=(40-GA)*7 I % S DOB=$$FMADD^XLFDT(DOB,-%)
  1. A2 I VDT<DOB Q ""
  1.  Q DOB
  1.  ; 
  1. ASQIEN(M) ; EP - GIVEN THE ASQ AGE IN MONTHS, RETURN THE CURRENT ASQ FORM IEN^IEN OF THE NEXT FORM
  1.  N IEN,X,Y,IEN2
  1.  I +$G(M)<3 Q ""
  1.  I M>61 Q ""
  1.  S IEN2=""
  1.  S IEN=$O(^AUTTASQ("B",M,0))
  1.  I IEN S Y=$O(^AUTTASQ("B",M)) S:Y IEN2=$O(^AUTTASQ("B",Y,0)) Q IEN_U_IEN2
  1.  S X=M-1,IEN=$O(^AUTTASQ("B",X,0))
  1.  I IEN S Y=$O(^AUTTASQ("B",X)) S:Y IEN2=$O(^AUTTASQ("B",Y,0)) Q IEN_U_IEN2
  1.  S X=M+1,IEN=$O(^AUTTASQ("B",X,0))
  1.  I IEN S Y=$O(^AUTTASQ("B",X)) S:Y IEN2=$O(^AUTTASQ("B",Y,0)) Q IEN_U_IEN2
  1.  S X=$O(^AUTTASQ("B",M),-1),IEN=$O(^AUTTASQ("B",X,0))
  1.  I IEN S Y=$O(^AUTTASQ("B",M)) S:Y IEN2=$O(^AUTTASQ("B",Y,0)) Q IEN_U_IEN2
  1.  Q ""
  1.  ;