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