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

VENPCCQ.m

Go to the documentation of this file. 
  1. VENPCCQ ; IHS/OIT/GIS - KNOWLEDGEBASE UTILITIES FOR ASQ ; 21 Oct 2011  11:27 AM
  1.  ;;2.6;PCC+;**1,3,4**;APR 03, 2012;Build 24
  1.  ;
  1.  ;
  1.  ;
  1.  W $$NDT^VENPCCQ(3050101,30.15) Q
  1.  N DOB,M S DOB=3080107 S M=$$M(DOB) W !,$$ASQIEN(M) Q
  1. M(DOB) N Y1,Y2,M1,M2,D1,D2,YD,MD,M G A1
  1.  ; 
  1. ASQ ; EP - GET ASQ SCORES IN u40-u52 ; WCM UPGRADE
  1.  S IDT=0,STOP=0
  1.  F  S IDT=$O(^AUPNVWC("AA",DFN,IDT)) Q:'IDT  D  I STOP Q
  1.  . S WCIEN=0
  1.  . F  S WCIEN=$O(^AUPNVWC("AA",DFN,IDT,WCIEN)) Q:'WCIEN  D  I STOP Q
  1.  .. S %=$G(^AUPNVWC(WCIEN,2)) I '$L(%) Q
  1.  .. I %?1."^" Q
  1.  .. S VIEN=$P($G(^AUPNVWC(WCIEN,0)),U,3) I 'VIEN Q
  1.  .. S FMDT=+^AUPNVSIT(VIEN,0)\1
  1.  .. S VDT=$$FMTE^XLFDT(FMDT,2) ; DATE OF LAST ASQ
  1.  .. S Z=40,@TMP@("u40")=VDT,STOP=1
  1.  .. F PCE=1:1:5,7 D
  1.  ... S X=$P(%,U,PCE)
  1.  ... S Z=Z+1,MN="u"_Z
  1.  ... K @TMP@(MN)
  1.  ... I $L(X),PCE=7 S X=$P($G(^VEN(7.14,X,0)),U)
  1.  ... I $L(X) S @TMP@(MN)=X
  1.  ... Q
  1.  .. Q
  1.  . Q
  1. ASQNOW ; EP -GET TODAYS ASQ MONTH AND CUTOFF SCORES
  1.  S M=$$ASQAGE(DFN) I 'M Q
  1.  S QIEN=+$$ASQIEN(M) I 'QIEN Q
  1.  S %=$G(^VEN(7.14,QIEN,0)) I '$L(%) Q
  1.  S @TMP@("u47")=$P(%,U,1) ; QUESTIONNAIRE (MONTH)
  1.  S @TMP@("u48")=$P(%,U,4) ; FINE MOTOR CUTOFF
  1.  S @TMP@("u49")=$P(%,U,3) ; GROSS MOTOR CUTOFF
  1.  S @TMP@("u50")=$P(%,U,2) ; COMMUNICATION CUTOFF
  1.  S @TMP@("u51")=$P(%,U,6) ; PERSONAL-SOCIAL CUTOFF
  1.  S @TMP@("u52")=$P(%,U,5) ; PROBLEM SOLVING CUTOFF
  1.  Q
  1.  ;
  1. NAME(X) ; EP - FROM TRIGGER IN VEN EHP KB ASQ FILE
  1.  ; CONVERT # MOS TO ASQ FILE NAME
  1.  I '$G(X) Q ""
  1.  I $L(X)=1 S X="0"_X
  1.  S X=X_" Month Questionnaire.pdf"
  1.  Q X
  1.  ; 
  1. INT(OUT,IN) ; EP - RPC: VEN ASQ INTERVENTION FORM
  1.  ; GIVEN A DFN, RETURNT THE NAME OF THE APPROPRIATE ASQ INTERVENTION FORM
  1.  S OUT=""
  1.  I '$D(^DPT(+$G(IN),0)) Q
  1.  N NAME,X,Y,Z,%,DFN
  1.  S DFN=+IN,%=$$ASQAGE(DFN) I %<2!(%>66) Q
  1.  S X=$S(%<4:1,%<8:4,%<12:8,%<16:12,%<20:16,%<24:20,%<30:24,%<36:30,%<48:36,%<60:48,%<66:60,1:"") I 'X Q
  1.  S Y=$S(X=1:4,X=4:8,X=8:12,X=12:16,X=16:20,X=20:24,X=24:30,X=30:36,X=36:48,X=48:60,X=60:66,1:"") I 'Y Q
  1.  I $L(X)=1 S X="0"_X
  1.  I $L(Y)=1 S Y="0"_Y
  1.  S OUT="Activities "_X_"-"_Y_" months.pdf"
  1.  Q
  1.  ;
  1. ASQAGE(DFN,DATE) ; EP - GIVEN A DFN AND REFERENCE DATE (DEFAULTS TO TODAY), RETURN THE ASQ AGE IN MM.DD FORMAT; E.G., "30.15"
  1.  N Y1,Y2,M1,M2,D1,D2,YD,MD,M,DOB,MDT,YDT,BDT,DDT
  1.  I '$G(DATE),'$G(DT) Q ""
  1.  S DOB=$$ASQDOB(DFN)
  1. A1 S Y1=+$E(DOB,1,3),M1=+$E(DOB,4,5),D1=+$E(DOB,6,7)
  1.  I '$G(DATE) S DATE=DT
  1.  S Y2=+$E(DATE,1,3),M2=+$E(DATE,4,5),D2=+$E(DATE,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.  S YDT=Y1+(M\12)
  1.  S MDT=M1+(M#12)
  1.  I MDT>12 S YDT=YDT+1,MDT=MDT-12
  1.  I MDT<10 S MDT="0"_MDT
  1.  I D1<10 S D1="0"_D1
  1.  S BDT=YDT_MDT_D1
  1.  S DDT=$$FMDIFF^XLFDT(DATE,BDT)
  1.  I DDT<10 S DDT="0"_DDT
  1.  Q (M_"."_DDT)
  1.  ;
  1. DOBAGE(DFN,DATE) ; EP - GIVEN A DFN, RETURN THE DOB AGE IN MONTHS
  1.  I $G(DFN),$G(DT)
  1.  E  Q ""
  1.  N M,DOB,Y1,M1,D1,Y2,M2,D2,MD,YD,M
  1.  S DOB=$P($G(^DPT(DFN,0)),U,3) I 'DOB Q ""
  1.  S Y1=+$E(DOB,1,3),M1=+$E(DOB,4,5),D1=+$E(DOB,6,7)
  1.  I '$G(DATE) S DATE=DT
  1.  S Y2=+$E(DATE,1,3),M2=+$E(DATE,4,5),D2=+$E(DATE,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. ASQDOB(DFN) ; EP - GIVEN A DFN, RETURN THE ADJUSTED (ASQ) DOB
  1.  N DOB,GA,%
  1.  S DOB=$P($G(^DPT(+$G(DFN),0)),U,3)
  1.  I '$G(DOB) Q ""
  1.  I $$DOBAGE(DFN)>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 DT<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.  ; REVISED FOR ASQ3
  1.  N IEN,X,Y,Z,%,IEN2,STG,ISTG,ISTG2,PCE,STOP,AGE
  1.  I +$G(M)<1 Q "" ; OUT OF RANGE ON LOW END
  1.  I M>66.0 Q "" ; OUT OF RANGE ON HIGH END
  1.  S AGE=0,(STG,ISTG)="",PCE=0
  1.  F  S AGE=$O(^VEN(7.14,"B",AGE)) Q:'AGE  D  ; BUILD THE REFERENCE DATA SET
  1.  . S IEN=$O(^VEN(7.14,"B",AGE,0)) I 'IEN Q
  1.  . S STOP=$P($G(^VEN(7.14,IEN,2)),U,2) I STOP="" Q
  1.  . S %=$O(^VEN(7.14,"B",AGE))
  1.  . S PCE=PCE+1
  1.  . S $P(STG,U,PCE)=STOP
  1.  . S $P(ISTG,U,PCE)=IEN
  1.  . Q
  1. AIEN F PCE=1:1:$L(STG,U) S Z=$P(STG,U,PCE) I Z'<M Q  ; GET QUESTIONNAIRE AGE GROUP
  1.  S IEN=$P(ISTG,U,PCE) I 'IEN Q "" ; GET QUESTIONNAIRE IEN
  1.  S IEN2=$P(ISTG,U,PCE+1) ; NEXT QUESTIONNAIRE
  1.  Q IEN_U_IEN2 ; CURRENT QUESTIONNAIRE IEN AND NEXT QUESTIONNAIRE IEN
  1.  ; 
  1.  ; DEAD CODE USED WITH ASQ VER 2
  1.  I M>60 S M=60
  1.  S IEN2=""
  1.  S IEN=$O(^VEN(7.14,"B",M,0))
  1.  I IEN S Y=$O(^VEN(7.14,"B",M)) S:Y IEN2=$O(^VEN(7.14,"B",Y,0)) Q IEN_U_IEN2
  1.  S X=M+1,IEN=$O(^VEN(7.14,"B",X,0))
  1.  I IEN S Y=$O(^VEN(7.14,"B",X)) S:Y IEN2=$O(^VEN(7.14,"B",Y,0)) Q IEN_U_IEN2
  1.  S X=M-1,IEN=$O(^VEN(7.14,"B",X,0))
  1.  I IEN S Y=$O(^VEN(7.14,"B",X)) S:Y IEN2=$O(^VEN(7.14,"B",Y,0)) Q IEN_U_IEN2
  1.  S X=$O(^VEN(7.14,"B",M),-1),IEN=$O(^VEN(7.14,"B",X,0))
  1.  I IEN S Y=$O(^VEN(7.14,"B",M)) S:Y IEN2=$O(^VEN(7.14,"B",Y,0)) Q IEN_U_IEN2
  1.  Q ""
  1.  ;
  1. ASQDTR(DFN) ; EP - GIVEN A DFN RETURN THE DATE RANGE FOR THE NEXT ASQ
  1.  N M,ASQM,DATE,DOB,Y,M,D,START,FIN,MS,YS,MF,YF,%,IEN
  1.  S DOB=$$ASQDOB(DFN) I 'DOB Q ""
  1.  S M=$$ASQAGE(+$G(DFN)) I M="" Q ""
  1.  S %=$$ASQIEN(M) I '$L(%) Q ""
  1.  S IEN=$P(%,U,2) I 'IEN Q "" ; GET IEN OF NEXT ASQ QUESTIONNAIRE.  IF THERE IS NONE, QUIT HERE.
  1.  S %=$G(^VEN(7.14,IEN,2))
  1.  S AGE1=$P(%,U),AGE2=$P(%,U,2)
  1.  S START=$$NDT(DOB,AGE1),FIN=$$NDT(DOB,AGE2)
  1.  Q (START_U_FIN)
  1.  ;
  1. NDT(DOB,AGE) ; ADD MM.DD TO AN FM DOB
  1.  I $G(DOB),$G(AGE)
  1.  E  Q ""
  1.  N X,Y,Z,%,M,D,Y,NDT,NY,NM,DT1
  1.  S M=+(AGE\1)
  1.  S D=$P(AGE,".",2)
  1.  S NY=$E(DOB,1,3)+(M\12)
  1.  S NM=+$E(DOB,4,5)+(M#12)
  1.  I NM>12 S NM=NM-12,NY=NY+1
  1.  I $L(NM)=1 S NM="0"_NM
  1.  S DT1=NY_NM_$E(DOB,6,7)
  1.  S NDT=$$FMADD^XLFDT(DT1,D)
  1.  Q NDT
  1.  ; 
  1. AD1 ; DEAD CODE FROM ASQ VER 2.0
  1.  S ASQM=+$G(^VEN(7.14,IEN,0)) I 'ASQM Q ""
  1.  I ASQM<M S IEN=IEN+1 G AD1
  1.  S Y=$E(DOB,1,3),M=$E(DOB,4,5),D=$E(DOB,6,7)
  1.  S Y=Y+(ASQM\12),M=M+(ASQM#12)
  1.  I M>12 S Y=Y+1,M=M-12 ; THIS IS THE CENTER MONTH AND YEAR
  1.  S MS=M-1,YS=Y
  1.  I 'MS S MS=12,YS=YS-1
  1.  I $L(MS)=1 S MS="0"_MS
  1.  S MF=M+1,YF=Y
  1.  I MF=13 S MF=1,YF=YF+1
  1.  I $L(MF)=1 S MF="0"_MF
  1.  S START=YS_MS_D,FIN=YF_MF_D
  1.  I START<DT S IEN=IEN+1 G AD1
  1.  Q (START_U_FIN)
  1.  ;
  1. DATA(OUT,IN) ; EP - RPC: VEN ASQ GET DATA
  1.  ; IN = DFN
  1.  S OUT=""
  1.  N STG,DFN,NAME,DOB,CDOB,TODAY,CHART,MOM,REL,PHONE,STREET,CITY,STATE,ZIP,ASQ,NEXT,B,X,Y,Z,%,M,PAGE,GA,SEX
  1. INIT S STG=$G(^DPT(+$G(IN),0)) I '$L(STG) Q
  1.  S (CHART,MOM,REL,PHONE,STREET,CITY,STATE,ZIP,NEXT)=""
  1.  S B="|",DFN=+IN,GA=$P(IN,"|",2)
  1. ITEMS S NAME=$P(STG,U) I '$L(NAME) Q
  1.  S DOB=$P(STG,U,3) I 'DOB Q
  1.  S %=$P(STG,U,2)
  1.  S SEX=$S(%="M":"Male",%="F":"Female",1:"")
  1.  S CDOB=$$ASQDOB(DFN)
  1.  I CDOB=DOB S CDOB=""
  1.  S DOB=$$FMTE^XLFDT(DOB,1)
  1.  I CDOB S CDOB=$$FMTE^XLFDT(CDOB,1)
  1.  S TODAY=$$FMTE^XLFDT(DT,1)
  1.  S (ASQ,MONTH,PAGE)=""
  1.  S M=$$ASQAGE(DFN) I 'M G PAGE
  1.  S X=$$ASQIEN(M) I '$L(X) G PAGE
  1.  S ASQ=$G(^VEN(7.14,+X,1)) I '$L(ASQ) Q  ; PDF FILE NAME
  1.  S MONTH=+ASQ
  1.  S PAGE=$P($G(^VEN(7.14,+X,0)),U,7) I 'PAGE Q
  1. PAGE S X=$$ASQDTR(DFN) I $L(X) S NEXT=$$FMTE^XLFDT(+X,1)_" to "_$$FMTE^XLFDT($P(X,U,2),1)
  1.  S X=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),"^",2) I $L(X) S CHART=X
  1.  S X=$P($G(^DPT(DFN,.24)),U,2) I $L(X) S MOM=X,REL="Mother"
  1.  S X=$P($G(^DPT(DFN,.13)),U,1) I $L(X) S PHONE=X
  1.  S X=$P($G(^DPT(DFN,.11)),U,1) I $L(X) S STREET=X
  1.  S X=$P($G(^DPT(DFN,.11)),U,4) I $L(X) S CITY=X
  1.  S X=$P($G(^DPT(DFN,.11)),U,5) I X S X=$P($G(^DIC(5,X,0)),U) I $L(X) S STATE=X
  1.  S X=$P($G(^DPT(DFN,.11)),U,6) I $L(X) S ZIP=X
  1.  S X=$P($G(^AUPNBMSR(DFN,0)),U,6) S GA=X
  1.  S OUT=NAME_B_DOB_B_CDOB_B_CHART_B_MOM_B_REL_B_PHONE_B_STREET_B_CITY_B_STATE_B_ZIP_B_ASQ_B_MONTH_B_PAGE_B_NEXT_B_GA_B_SEX
  1.  Q
  1.  ;
  1. HOLD(OUT,IN) ; EP - POPULATE THE ASQ HOLDING FILE
  1.  ; IN=PATIENT DFN, OUT="IEN1~IEN2"
  1.  ; DEAD CODE
  1.  S OUT="",DFN=+$G(IN) I '$D(^DPT(DFN,0)) Q
  1.  S DOB=$P(^DPT(DFN,0),U,3),GA=$P($G(^AUPNBMSR(DFN,0)),U,6) ; GA=ACTUAL GA
  1.  S XGA=40 I GA S XGA=GA ; XGA = ACTUAL GA.  IF ACTUAL GA NO AVAILABLE XGA=40
  1.  Q
  1.  ;
  1. GA(DFN,GA) ; EP - FILE THE GA
  1.  N DIC,DA,DR,DIE,X,Y,%
  1.  S DIC="^AUPNBMSR(",DIC(0)="L",DLAYGO=9000024,X="`"_DFN
  1.  D ^DIC I Y=-1 Q
  1.  S DIE=DIC,DA=+Y,DR=".06///^S X=GA"
  1.  L +^AUPNBMSR(DA):1 I  D ^DIE L -^AUPNBMSR(DA)
  1.  D ^XBFMK
  1.  Q
  1.  ; 
  1. PATIENT(OUT,IN) ; EP - RPC: VEN ASQ GET PATIENT ID
  1.  ; GIEN A CHART #, RETURN PATIENT IDENTIFIERS
  1.  I '$L($G(IN)) Q
  1.  N NAME,DOB,MOM,X,Y,%,HRN,AUPNPAT,AUPNSEX,AUPNDOB,AUPNDAYS,AUPNDOD,B,GA
  1.  S OUT="",HRN=IN,B="|"
  1.  S DIC="^AUPNPAT(",X=HRN,DIC(0)="M"
  1. PLK ; EP  - FOR ALT PROCESSING OF HRN
  1.  D ^DIC I Y=-1 Q
  1.  I $G(AUPNDOD) Q  ; PATIENT MUST BE ALIVE
  1.  I '$G(AUPNPAT) Q
  1.  S NAME=$P($G(^DPT(AUPNPAT,0)),U) I '$L(NAME) Q
  1.  S DOB=$$FMTE^XLFDT(AUPNDOB,"2D")
  1.  S MOM=$P($G(^DPT(AUPNPAT,.24)),U,2)
  1.  S GA=$P($G(^AUPNBMSR(AUPNPAT,0)),U,6)
  1.  S OUT=AUPNPAT_B_NAME_B_DOB_B_AUPNSEX_B_MOM_B_GA
  1.  D ^XBFMK
  1.  Q
  1.  ; 
  1. UGA(OUT,IN) ; EP - RPC: VEN ASQ UPDATE GESTATIONAL AGE
  1.  ; GIVEN ASQ DFN AND GA VALUE (DFN|VAL), UPDATE THE TX FILE AND RPMS
  1.  S OUT=""
  1.  I $G(IN)
  1.  E  Q
  1.  N GA,DFN,X,Y,Z,%,REF
  1.  S DFN=+$P(IN,"|",1) I '$D(^DPT(DFN,0)) Q
  1.  S GA=$P(IN,"|",2) I 'GA Q
  1.  D GA(DFN,GA)
  1.  S OUT="OK"
  1.  Q
  1.  ; 
  1. ASQX ; EP - MEASUREMENT VALIDATION - VALIDATE ASQ SCORE
  1.  N Y,Z,%
  1.  S %=$P(X," ")
  1.  I %'?1.2N,%'?1.2N1"."1.2N K X Q
  1.  S %=$P(X," ",2)
  1.  I %'?1"("1.2N1")",%'?1"("1.2N1"."1.2N1")" K X
  1.  Q
  1.  ;