VENPCCQ1 ; IHS/OIT/GIS - KNOWLEDGEBASE UTILITIES FOR ASQ GUI DATA CAPTURE ; 12 Jul 2011 7:49 AM
;;2.6;PCC+;**1,4**;APR 03, 2012;Build 24
;
D TX(.OUT,"27254|2677336") W !,OUT Q
D FLUSH(.OUT,"~1~4~1004~2199") W !,OUT Q
;
VISIT(OUT,IN) ; EP - RPC: VEN ASQ GET VISITS
; GIVEN DFN, RETURN PATIENT IDENTIFIERS AND CANDIDATE VISIT IDENTIFIERS
I '$D(^DPT(+$G(IN),0)) Q
N NAME,DOB,MOM,X,Y,%,AUPNPAT,AUPNSEX,AUPNDOB,AUPNDAYS,AUPNDOD,B,GA,DFN,TS,VSTG,CSIEN,CS
S OUT="",B="|",DFN=+IN
S DIC="^AUPNPAT(",X="`"_DFN,DIC(0)="M"
D PLK^VENPCCQ I OUT="" Q
S IDT=9999999-(DT\1),BDT=9999999-$$FMADD^XLFDT(DT,-365)
S IDT=IDT-.0000001,VSTG=""
F S IDT=$O(^AUPNVSIT("AA",DFN,IDT)) Q:'IDT Q:IDT>BDT S VIEN=0 F S VIEN=$O(^AUPNVSIT("AA",DFN,IDT,VIEN)) Q:'VIEN D
. S X=$G(^AUPNVSIT(VIEN,0)) I '$L(X) Q
. S TS=$$FMTE^XLFDT(+X) I '$L(TS) Q
. S CSIEN=$P(X,U,8) I 'CSIEN Q
. S CS=$P($G(^DIC(40.7,CSIEN,0)),U) I '$L(CS) Q
. S VSTG=VSTG_"\"_VIEN_B_TS_B_CS
. Q
I $L($G(VSTG)) S OUT=OUT_VSTG
Q
;
TX(OUT,IN) ; EP - RPC: VEN ASQ START TX
; GIVEN DFN|VIEN POPULATE THE TX FILE AND RETURN THE TABLE GEN STRING
HX ; EP FROM HXASQ
S OUT=0
N B,DFN,VIEN,M,MOS1,MOS2,ASQAGE,CAGE,ASQ1,ASQ2,DATE1,DATE2,DOB,ADOB,GA,F1,FC1,F2,FC2,G1,GC1,G2,GC2,C1,CC1,C2,CC2
N S1,SC1,S2,SC2,P1,PC1,P2,PC2,DIC,DIE,DA,DR,LSTG,PCE,V,C,TODAY,DIK,DIC,DIE,DLAYGO,DA,DR,QIEN,FMDT,TABLE,EDOB,FLD
N AUPNPAT,AUPNSEX,AUPNDOB,AUPNDAYS,AUPNDOD,MULT,TVIEN,LOCKED,START,FIN,VDT,X,Y,Z,%,OPEN,EDIT,LDT,MVIEN,VIEN,ASQM,OLD
S B="|"
S DFN=+$G(IN) I '$D(^DPT(DFN,0)) Q
S TODAY=$P(IN,B,4)
S VDT=+$G(^AUPNVSIT(+$G(TVIEN),0))\1
I 'VDT S VDT=$G(DT)
S DATE=VDT
CLEANUP S DIK="^VEN(7.15,",DA=0
F S DA=$O(^VEN(7.15,"B",DFN,DA)) Q:'DA D ^DIK ; DELETE ALL ASQ TX FILE ENTRIES FOR THIS PATIENT
S TVIEN=+$P(IN,B,2) ; TODAYS VISIT
POP N LSTG0,LSTG1
D MLSTG(DFN,TVIEN,.LSTG0,.LSTG1) ; GET ALL THE ASQ RESULTS - INCLUDING RESULTS RESULTS FOR CURRENT VISIT
; I '$L(LSTG0),'$G(TVIEN) Q ; NO PAST RESULTS AND NO CURRENT VISIT SPECIFIED, SO QUIT (OUT=0)
I '$L(LSTG0) D T1(DFN,DATE,TVIEN,.TODAY,.START,.FIN) S EDIT=1002 G OUT ; NO ASQ RESULTS FOUND - NEW ROW ONLY
; AT THIS POINT WE KNOW THERE IS OLD DATA
D MPOP(DFN,LSTG0,LSTG1,.START,.FIN) ; POPULATE THE TX TABLE WITH ASQ RESULTS: START/FIN ARE DEFINED
; I '$G(TVIEN) S EDIT=1001 G OUT ; CURRENT VISIT NOT SPECIFIED - ONLY ALLOW OLD ROWS
; AT THIS POINT WE KNOW THERE IS A CURRENT VISIT
I $$FMDIFF^XLFDT(DT,VDT)>3 S EDIT=1001 G OUT ; CURRENT VISIT >72 HRS OLD - ONLY ALLOW OLD ROWS
S ASQM=$O(^AUTTMSR("C",66,0)),Z=999999999,OLD=0
I $G(TVIEN) F S Z=$O(^AUPNVMSR("AD",TVIEN,Z),-1) Q:'Z I +$G(^AUPNVMSR(Z,0))=ASQM S OLD=1 Q ; CHECK TO SEE IF THERE IS ALREADY ASQ DATA FOR THIS VISIT
I 'OLD D T1(DFN,DATE,TVIEN,.TODAY,.START,.FIN) S EDIT=1003 G OUT ; NO CURRENT ROW: NEW ROW ADDED + OLD DATA
; AT THIS POINT WE KNOW THERE IS ASQ DATA ASSOCIATED WITH THE CURRENT VISIT
S X=$O(^AUPNVMSR("AA",DFN,+ASQM,0)) ; GET CURRENT ASQ
I ((9999999-X)\1)<VDT S EDIT=1001 G OUT ; CURRENT VISIT IS NOT THE MOST RECENT ASQ VISIT: CURRENT ROW IS LOCKED - ALLOW OLD DATA ONLY
S EDIT=1004 ; CURRENT ROW IS EDITABLE (CURRENT ROW IS PART OF OLD DATA SET)
OUT S OUT="BMX ADO SS^VEN ASQ TX^^~"_START_"~"_FIN_"~"_EDIT ; GET TABLE GEN STRING FOR THIS ASQ MEASUREMENT
D ^XBFMK
; THE VARIABLE 'TABLE' TELLS THE OBJECT WHAT CAN BE DONE: 1001=OLD VALUES ONLY,1002=NEW VALUE ONLY,1003=OLD AND 1 NEW ROW,1004=OLD WITH 1 EDITABLE ROW
Q
;
T1(DFN,DATE,TVIEN,TODAY,START,FIN) ; BUILD NEW ROW
S TODAY="",START=$G(START),FIN=$G(FIN)
I $G(DATE),$G(DFN)
E Q
N X,Y,Z,%,DOB,EDOB,MOS2,ADOB,GA,ASQ2,FC2,GC2,CC2,SC2,DATE2,DIC,DIE,DA,DR,M,QIEN
S M=$$ASQAGE^VENPCCQ(DFN,DATE) I 'M Q ; ADJUSTED (ASQ) AGE IN MOS
S QIEN=+$$ASQIEN^VENPCCQ(M) I 'QIEN Q ; QUESTIONNAIRE IEN
S DOB=$P($G(^DPT(DFN,0)),U,3)
S EDOB=$$FMTE^XLFDT(DOB,"2D") ; PRINTED DOB
S MOS2=$$DOBAGE^VENPCCQ(DFN,DATE) ; CHRONOLICAL AGE IN MONTHS
S ADOB=$$ASQDOB^VENPCCQ(DFN) ; ADJUSTED (ASQ) DOB
I ADOB S ADOB=$$FMTE^XLFDT(ADOB,"2D")
S GA=$P($G(^AUPNBMSR(DFN,0)),U,6) ; GESTATIONAL AGE FROM BIRTH MEASUREMENT FILE
S %=$G(^VEN(7.14,QIEN,0)) I '$L(%) Q
S ASQ2=$P(%,U,1) ; QUESTIONNAIRE (MONTH)
S FC2="("_$P(%,U,4)_")" ; FINE MOTOR CUTOFF
S GC2="("_$P(%,U,3)_")" ; GROSS MOTOR CUTOFF
S CC2="("_$P(%,U,2)_")" ; COMMUNICATION CUTOFF
S SC2="("_$P(%,U,6)_")" ; PERSONAL-SOCIAL CUTOFF
S PC2="("_$P(%,U,5)_")" ; PROBLEM SOLVING CUTOFF
S DATE2=$$FMTE^XLFDT(DATE,"2D")
S DIC="^VEN(7.15,",DIC(0)="L",DLAYGO=19707.15,X=""""_DFN_""""
D ^DIC I Y=-1 S IEN="" D ^XBFMK Q
I '$G(START) S START=+Y ; IEN IN THE ASQ TX FILE FOR TODAY'S NEW ENTRY
S (TODAY,FIN)=+Y
S ^VEN(7.15,+Y,0)=DFN_U_DATE2_U_ASQ2_U_MOS2_U_EDOB_U_ADOB_U_GA_U_TVIEN
S ^VEN(7.15,+Y,1)=U_FC2_U_"*"_U_GC2_U_"*"_U_CC2_U_"*"_U_SC2_U_"*"_U_PC2_U_"*"
D ^XBFMK
Q
;
LSTG(DFN) ; EP - GET LAST ASQ VALUES
; DEAD CODE
N LSTG,IDT,STOP,WCIEN,STG,PCE,V,C,X,Y,Z,%
N F1,FC1,G1,GC1,C1,CC1,S1,SC1,P1,PS1,ASQIEN
S LSTG=""
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 STG=$G(^AUPNVWC(WCIEN,2)) I '$P(STG,U,7) Q
.. I STG?1."^" Q
.. S VIEN=$P($G(^AUPNVWC(WCIEN,0)),U,3) I 'VIEN Q
.. S FMDT=+^AUPNVSIT(VIEN,0)\1
.. S DATE1=$$FMTE^XLFDT(FMDT,2) ; DATE OF LAST ASQ
.. S ASQIEN=$P(STG,U,7) I 'ASQIEN Q ; MUST HAVE A VALID ASQ IEN
.. S ASQ1=+$G(^VEN(7.14,ASQIEN,0)) I 'ASQ1 Q ; MUST HAVE A VALID QUESTIONNAIRE MONTH
.. S MOS1=$$LASTAGE(DFN,FMDT) ; GET AGE IN MOS AT LAST VISIT
.. S STOP=1
.. F PCE=1:1:5 D
... S %=$E("FGCSP",PCE)
... S V=%_1,C=%_"C1"
... S X=$P(STG,U,PCE),Y=+X,Z=+$P(X,"(",2)
... I $P(X," ")'="" S @V=Y
... I Z S @C=Z
... Q
.. Q
. Q
S LSTG=$G(F1)_U_$G(FC1)_U_$G(G1)_U_$G(GC1)_U_$G(C1)_U_$G(CC1)_U_$G(S1)_U_$G(SC1)_U_$G(P1)_U_$G(PC1)
Q LSTG
;
LASTAGE(DFN,DT) ; EP - GET LAST AGE IN MONTHS
Q $$DOBAGE^VENPCCQ(DFN)
;
FLUSH(OUT,IN) ; EP - RPC: VEN ASQ FLUSH
; FLUSH ASQ DATA OUT OF TX FILE INTO V FILES
S OUT=""
N IEN,DIC,DIE,DA,DR,X,Y,Z,%,VIEN,VDT,XDT,TIEN,DFN,ASQ,F,FC,G,GC,C,CC,S,SC,P,PC,ASQIEN,NOW,PRVIEN
N DATE,FMDT,%DT,PCE,STG,V1,V2,GBL,VSTG,VAL,ENT,PRVIEN,NOW,EDT,RDT,KALL,ROW
S IEN(1)=+$P($G(IN),"~",2),IEN(2)=+$P($G(IN),"~",3),IEN(3)=$P($G(IN),"~",4)
I IEN(3),IEN(2),IEN(1)
E Q
S ROW=$S(IEN(3)=1003:IEN(2),1:IEN(1)) I 'ROW Q
S TIEN=ROW,PRVIEN=+$P($G(IN),"~",5) ; ,NOW=$E($$NOW^XLFDT,1,12)
S DFN=+$G(^VEN(7.15,ROW,0)) I 'DFN Q
S VIEN=$P(^VEN(7.15,ROW,0),U,8) I 'VIEN Q
S VDT=+$G(^AUPNVSIT(VIEN,0))\1 I 'VDT Q
FL1 S X=$G(^VEN(7.15,TIEN,0))
S DFN=+X,ASQ=$P(X,U,3),DATE=$P(X,U,2),EDT="",RDT=$G(DT)
FL2 S ASQIEN=$O(^VEN(7.14,"B",+$G(ASQ),0))
I 'ASQIEN D ASQCLEAN(VIEN) S OUT="OK" Q ; ASQ FORM NOT DEFINED, SO DELETE ALL OF THE VISIT'S ASQ RESULTS AND QUIT
; S X=DATE D ^%DT S FMDT=Y
S STG=$G(^VEN(7.15,TIEN,1)) I '$L(STG) Q
F PCE=1:1:5 D
. S %=$E("FGCSP",PCE)
. S V1=%,V2=%_"C"
. I PCE=1 S X=$P(STG,U,11),Y=$P(STG,U,2)
. E S Z=(PCE*2)-1,X=$P(STG,U,Z),Y=$P(STG,U,Z+1)
. S Y=$TR(Y,"(",""),Y=$TR(Y,")","")
. S @V1=X,@V2=Y
. Q
S VSTG=F_" ("_FC_")^"_G_" ("_GC_")^"_C_" ("_CC_")^"_S_" ("_SC_")^"_P_" ("_PC_")^^"_ASQ
I $G(NOWC) G MEAS
WC ; V WELL CHILD ENTRY
S DA=$$VWC(DFN,VIEN) I 'DA G MEAS ; GET V WELL CHILD RECORD NUMBER
S GBL=$NA(^AUPNVWC(DA,2))
S @GBL=VSTG
MEAS ; V MEASUREMENTS ENTRY
S KALL=0,DA=""
F PCE=7,1:1:5 S VAL=$P(VSTG,U,PCE) D
. I PCE=7,+VAL=0 S KALL=1 ; KILL ALL ASQ MEASUREMENTS FOR THIS VISIT
. E I PCE=7,$O(^VEN(7.14,"B",+$G(VAL),0))="" S KALL=1 ; MUST BE A LEGIT ASQ MONTH
. I +VAL=0!(KALL) S VAL="@" ; DELETE THE V MEASUREMENT ENTRY
. D ASQVMSR(PCE,VAL,VIEN,VDT,PRVIEN,EDT,RDT) ; MAKE INDIVIDUAL V MEAS ENTRIES
. Q
DEL S DIK="^VEN(7.15,",DA=""
F S DA=$O(^VEN(7.15,"B",DFN,DA)) Q:'DA I $D(^VEN(7.15,DA)) D ^DIK ; CLEAN UP THE TX FILE
S OUT="OK"
D ^XBFMK
Q
;
ASQCLEAN(VIEN) ; IF THERE IS NO ASQ MONTH VALUE, CLEAN OUT ALL ASQ RESULTS FOR THIS VISIT.
I VIEN
E Q
N DIC,DIE,DA,DR,DIK,X,Y,Z,%,MVIEN,WREF
S DA=0,WREF="^AUPNVWC",DIK="^AUPNVMSR("
F S DA=$O(^AUPNVWC("AD",VIEN,DA)) Q:'DA K @WREF@(DA,2) ; CLEAN OUT THE ASQ NODE (2) IN THE V WELL CHILD FILE
F S DA=$O(^AUPNVMSR("AD",VIEN,DA)) Q:'DA D
. S X=+$G(^AUPNVMSR(DA,0)) I 'X Q
. S Y=$P($G(^AUTTMSR(X,0)),U) I $E(Y,1,3)'="ASQ" Q
. D ^DIK
. Q
D ^XBFMK
Q
;
EHRFLUSH(OUT,IN) ; EP - VEN ASQ EHR FLUSH
; GIVEN THE PATIENT IEN, FLUSH TODAY'S ASQ RESULTS TO THE V MEASUREMENT FILE
S OUT=""
I $G(IN),$D(^AUPNVSIT(+IN,0))
E Q
N DFN,VSTG,TIEN,X,Y,Z,%,VIEN,NOWC,ASQ,DATE,ASQIEN,STG,PCE,V1,V2,VSTG,VAL,DIK,DIC,DIE,DA,DR,VDT
S VIEN=+IN
S VDT=+$G(^AUPNVSIT(VIEN,0))\1 I 'VDT Q
S DFN=$P($G(^AUPNVSIT(VIEN,0)),U,5) I 'DFN Q
S TIEN=99999999
F S TIEN=$O(^VEN(7.15,"B",DFN,TIEN),-1) Q:'TIEN I $P($G(^VEN(7.15,TIEN,0)),U,8)=VIEN Q ; FIND THE ROW ASSOCIATED WITH TODAY'S VISIT
I TIEN S NOWC=1 D FL1 S DA=TIEN,DIK="^VEN(7.15," D ^DIK,^XBFMK
Q
;
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,VDT,GBL
S VDT=+$G(^AUPNVSIT(VIEN,0))\1 I 'VDT Q ""
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 Q ""
S GBL="^AUPNVWC"
S DA=+Y,DIE=DIC,DR=".02////^S X=DFN;.03////^S X=VIEN"
L +^AUPNVWC(DA):1 I D ^DIE L -^AUPNVWC(DA)
S @GBL@("AC",DFN,DA)="",@GBL@("AD",VIEN,DA)="",@GBL@("AA",DFN,9999999-VDT,DA)=""
Q DA
;
ASQVMSR(PCE,VAL,VIEN,VDT,PRVIEN,EDT,RDT) ; EP - FILE ASQ SCORES IN V MEASUREMNTS
N DIE,DIC,DA,DR,X,Y
S DIE="^AUPNVMSR("
S X=$P("ASQF^ASQG^ASQL^ASQS^ASQP^^ASQM",U,PCE) I X="" Q
S DA=$$VMSR(VIEN,X,VAL) I 'DA Q ; FIND EXISTING V MEASUREMENT, OR MAKE A NEW ONE, OR KILL OLD ONE IF VAL="@"
I VAL="@" Q
S DR=".04////^S X=VAL;.08////^S X=PRVIEN;1204////^S X=PRVIEN"
I $P($G(^AUPNVMSR(DA,0)),U,2)="" S DR=".02////^S X=DFN;.03////^S X=VIEN;"_DR
I '$G(EDT) S EDT=$G(VDT)\1
I $G(EDT) S DR=DR_";1201////^S X=EDT"
I $G(RDT) S DR=DR_";.07////^S X=RDT"
SETMSR L +^AUPNVMSR(DA):1 I D ^DIE L -^AUPNVMSR(DA)
Q
;
VMSR(VIEN,TYPE,VAL) ; EP - FIND OR CREATE A V MEASUREMENT ENTRY
N MIEN,VMIEN,DIC,X,Y,DIK,DA
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,VAL="@" S DIK="^AUPNVMSR(",DA=VMIEN D ^DIK K DIK,DA ; DELETE EXISTING ENTRY BECAUSE THERE IS NO VALUE
I VAL="@" Q "" ; NO NEW V MED ENTRY BECAUSE VAL IS NULL
I VMIEN Q VMIEN ; A V MEAS ENTRY ALREADY EXISTS FOR THIS ASQ CATEGORY AND VISIT
; AT THIS POINT THERE IS NO EXISTING ENTRY BUT THERE IS A VALID VALUE, SO MAKE A NEW V MEAS ENTRY STUB
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
;
MLSTG(DFN,TVIEN,LSTGX,LSTG1) ; EP - GET LAST ASQ VALUES
S LSTGX="",LSTG1=""
N IDT,STOP,STG,PCE,V,C,X,Y,Z,%,ASQIEN,VIEN
N ASQA,ASQF,ASQG,ASQL,ASQM,ASQP,ASQS,I,STG,TYPE,RIEN,VMIEN,MSR,MTYP
N F,FC,G,GC,L,LC,S,SC,P,PC,VAL,MIEN,ASQ1,MOS1,DATE1,FMDT,REDT,CUT,CP,FIEN,VARR,MOS
S STG="AFGLMPS"
F I=1:1:$L(STG) S X=$E(STG,I) S Y=$O(^AUTTMSR("B",("ASQ"_X),0)) Q:'Y S @("ASQ"_X)=Y
I '$G(ASQM) Q ; THIS IS THE ONLY REQUIRED MEASUREMENT
S IDT=0,STOP=0
F S IDT=$O(^AUPNVMSR("AA",DFN,ASQM,IDT)) Q:'IDT D ; BUILD VISIT ARRAY BASED ON THE EXISTANCE OF ASQM
. S MIEN=9999999999
. F S MIEN=$O(^AUPNVMSR("AA",DFN,ASQM,IDT,MIEN),-1) Q:'MIEN D
.. S VIEN=$P($G(^AUPNVMSR(MIEN,0)),U,3) I 'VIEN Q
.. S MOS=$P(^AUPNVMSR(MIEN,0),U,4) I 'MOS Q
.. S VARR(VIEN)=MOS
.. Q
. Q
F RIEN=ASQM,ASQA,ASQF,ASQG,ASQL,ASQP,ASQS D ; NOW GET ALL THE ASQ MEASUREMENTS FOR EACH VISIT
. S IDT=0
. S MTYP=$P($G(^AUTTMSR(RIEN,0)),U) I MTYP="" Q
. F S IDT=$O(^AUPNVMSR("AA",DFN,RIEN,IDT)) Q:'IDT D
.. S MIEN=9999999999
.. F S MIEN=$O(^AUPNVMSR("AA",DFN,RIEN,IDT,MIEN),-1) Q:'MIEN D
... S VIEN=$P($G(^AUPNVMSR(MIEN,0)),U,3) I '$D(VARR(+VIEN)) Q
... S VARR(VIEN,MIEN)=MTYP
... Q
.. Q
. Q
SV S VIEN=9999999999 F S VIEN=$O(VARR(VIEN),-1) Q:'VIEN D
. S FMDT=+^AUPNVSIT(VIEN,0)\1 I 'FMDT Q
. S (F,G,L,S,P)="" ; FOR EACH VISIT PROCESSED, REFRESH ALL VALUES
. S MOS=VARR(VIEN),FIEN=$O(^VEN(7.14,"B",MOS,0)) I 'FIEN Q ; ASQ FROM (MOS) AND ASQ FORM IEN
. S MIEN=0 F S MIEN=$O(VARR(VIEN,MIEN)) Q:'MIEN D
.. I $P($G(^AUPNVMSR(MIEN,2)),U) Q ; BYPASS ALL RESULTS ENTERED IN ERROR
.. S %=$P($G(^AUPNVMSR(MIEN,12)),U) I % S FMDT=%\1 ; EVENT DATE REPLACES VISIT DATE (IF AVAILABLE)
.. S DATE1=$$FMTE^XLFDT(FMDT,2) ; DATE OF LAST ASQ - EXTERNAL FORMAT
.. S MOS1=$$LASTAGE(DFN,FMDT) ; GET AGE IN MOS AT LAST VISIT
.. S REDT=$P($G(^AUPNVMSR(MIEN,0)),U,7) ; DATE RESULTS ENTERED
.. S MTYP=VARR(VIEN,MIEN)
.. S MSR=$E(MTYP,4) I MSR="" Q
.. D CUTOFF(MSR,FIEN)
.. S VAL=$P($G(^AUPNVMSR(MIEN,0)),U,4)
.. S @MSR=$P(VAL," ")
.. Q
. I $L(LSTGX) S LSTGX=LSTGX_"|"
. S LSTGX=LSTGX_DFN_U_$G(DATE1)_U_MOS_U_$G(MOS1)_U_$G(EDOB)_U_$G(ADOB)_U_$G(GA)_U_VIEN
. I $L(LSTG1) S LSTG1=LSTG1_"|"
. I VIEN=TVIEN F MSR="F","G","L","P","S" I @MSR="" D CUTOFF(MSR,FIEN) ; FOR CURRENT VISIT, MAKE SURE THAT THE CUTOFF SCORE IS ALWAYS DISPLAYED
. S LSTG1=LSTG1_U_$G(FC)_U_$G(G)_U_$G(GC)_U_$G(L)_U_$G(LC)_U_$G(S)_U_$G(SC)_U_$G(P)_U_$G(PC)_U_$G(F)
. Q
Q
;
CUTOFF(MSR,FIEN) ; POPULATE THE CUTOFF SCORE ARRAY
N CP,%
S CP=$S(MSR="F":4,MSR="G":3,MSR="L":2,MSR="P":5,MSR="S":6,1:"")
I CP="" Q
S %=$P($G(^VEN(7.14,FIEN,0)),U,CP) I '% Q ; FORM MOS
S @(MSR_"C")="("_%_")" ; THE CUTOFF VALUE IS A TEXT STRING - A NUMBER INSIDE PARENTHESES
Q
;
MPOP(DFN,LSTG0,LSTG1,START,FIN) ; GIVEN A PATIENT IEN AND ASQ RESULTS STRING, POPULATE THE ASQ TRANSACTION TABLE RETURNING THE STARTING IENS AKA LAST
S START="",FIN=""
I $G(DFN),$G(LSTG0)'="",$G(LSTG1)'=""
E Q
N X,Y,Z,DIC,DLAYGO,STG,PCE,STG1,STG0,MAX
S DIC="^VEN(7.15,",DIC(0)="LO",DLAYGO=19707.15,MAX=$L(LSTG1,"|")
F PCE=1:1:MAX D
. S STG0=$P(LSTG0,"|",PCE) I STG0="" Q
. S STG1=$P(LSTG1,"|",PCE) I STG1="" Q
. S X=""""_DFN_""""
. D ^DIC I Y=-1 Q
. I 'START S START=+Y
. S ^VEN(7.15,+Y,0)=STG0
. S ^VEN(7.15,+Y,1)=STG1
. S FIN=+Y
. Q
Q
;
VENPCCQ1 ; IHS/OIT/GIS - KNOWLEDGEBASE UTILITIES FOR ASQ GUI DATA CAPTURE ; 12 Jul 2011 7:49 AM
+1 ;;2.6;PCC+;**1,4**;APR 03, 2012;Build 24
+2 ;
+3 DO TX(.OUT,"27254|2677336")
WRITE !,OUT
QUIT
+4 DO FLUSH(.OUT,"~1~4~1004~2199")
WRITE !,OUT
QUIT
+5 ;
VISIT(OUT,IN) ; EP - RPC: VEN ASQ GET VISITS
+1 ; GIVEN DFN, RETURN PATIENT IDENTIFIERS AND CANDIDATE VISIT IDENTIFIERS
+2 IF '$DATA(^DPT(+$GET(IN),0))
QUIT
+3 NEW NAME,DOB,MOM,X,Y,%,AUPNPAT,AUPNSEX,AUPNDOB,AUPNDAYS,AUPNDOD,B,GA,DFN,TS,VSTG,CSIEN,CS
+4 SET OUT=""
SET B="|"
SET DFN=+IN
+5 SET DIC="^AUPNPAT("
SET X="`"_DFN
SET DIC(0)="M"
+6 DO PLK^VENPCCQ
IF OUT=""
QUIT
+7 SET IDT=9999999-(DT\1)
SET BDT=9999999-$$FMADD^XLFDT(DT,-365)
+8 SET IDT=IDT-.0000001
SET VSTG=""
+9 FOR
SET IDT=$ORDER(^AUPNVSIT("AA",DFN,IDT))
IF 'IDT
QUIT
IF IDT>BDT
QUIT
SET VIEN=0
FOR
SET VIEN=$ORDER(^AUPNVSIT("AA",DFN,IDT,VIEN))
IF 'VIEN
QUIT
Begin DoDot:1
+10 SET X=$GET(^AUPNVSIT(VIEN,0))
IF '$LENGTH(X)
QUIT
+11 SET TS=$$FMTE^XLFDT(+X)
IF '$LENGTH(TS)
QUIT
+12 SET CSIEN=$PIECE(X,U,8)
IF 'CSIEN
QUIT
+13 SET CS=$PIECE($GET(^DIC(40.7,CSIEN,0)),U)
IF '$LENGTH(CS)
QUIT
+14 SET VSTG=VSTG_"\"_VIEN_B_TS_B_CS
+15 QUIT
End DoDot:1
+16 IF $LENGTH($GET(VSTG))
SET OUT=OUT_VSTG
+17 QUIT
+18 ;
TX(OUT,IN) ; EP - RPC: VEN ASQ START TX
+1 ; GIVEN DFN|VIEN POPULATE THE TX FILE AND RETURN THE TABLE GEN STRING
HX ; EP FROM HXASQ
+1 SET OUT=0
+2 NEW B,DFN,VIEN,M,MOS1,MOS2,ASQAGE,CAGE,ASQ1,ASQ2,DATE1,DATE2,DOB,ADOB,GA,F1,FC1,F2,FC2,G1,GC1,G2,GC2,C1,CC1,C2,CC2
+3 NEW S1,SC1,S2,SC2,P1,PC1,P2,PC2,DIC,DIE,DA,DR,LSTG,PCE,V,C,TODAY,DIK,DIC,DIE,DLAYGO,DA,DR,QIEN,FMDT,TABLE,EDOB,FLD
+4 NEW AUPNPAT,AUPNSEX,AUPNDOB,AUPNDAYS,AUPNDOD,MULT,TVIEN,LOCKED,START,FIN,VDT,X,Y,Z,%,OPEN,EDIT,LDT,MVIEN,VIEN,ASQM,OLD
+5 SET B="|"
+6 SET DFN=+$GET(IN)
IF '$DATA(^DPT(DFN,0))
QUIT
+7 SET TODAY=$PIECE(IN,B,4)
+8 SET VDT=+$GET(^AUPNVSIT(+$GET(TVIEN),0))\1
+9 IF 'VDT
SET VDT=$GET(DT)
+10 SET DATE=VDT
CLEANUP SET DIK="^VEN(7.15,"
SET DA=0
+1 ; DELETE ALL ASQ TX FILE ENTRIES FOR THIS PATIENT
FOR
SET DA=$ORDER(^VEN(7.15,"B",DFN,DA))
IF 'DA
QUIT
DO ^DIK
+2 ; TODAYS VISIT
SET TVIEN=+$PIECE(IN,B,2)
POP NEW LSTG0,LSTG1
+1 ; GET ALL THE ASQ RESULTS - INCLUDING RESULTS RESULTS FOR CURRENT VISIT
DO MLSTG(DFN,TVIEN,.LSTG0,.LSTG1)
+2 ; I '$L(LSTG0),'$G(TVIEN) Q ; NO PAST RESULTS AND NO CURRENT VISIT SPECIFIED, SO QUIT (OUT=0)
+3 ; NO ASQ RESULTS FOUND - NEW ROW ONLY
IF '$LENGTH(LSTG0)
DO T1(DFN,DATE,TVIEN,.TODAY,.START,.FIN)
SET EDIT=1002
GOTO OUT
+4 ; AT THIS POINT WE KNOW THERE IS OLD DATA
+5 ; POPULATE THE TX TABLE WITH ASQ RESULTS: START/FIN ARE DEFINED
DO MPOP(DFN,LSTG0,LSTG1,.START,.FIN)
+6 ; I '$G(TVIEN) S EDIT=1001 G OUT ; CURRENT VISIT NOT SPECIFIED - ONLY ALLOW OLD ROWS
+7 ; AT THIS POINT WE KNOW THERE IS A CURRENT VISIT
+8 ; CURRENT VISIT >72 HRS OLD - ONLY ALLOW OLD ROWS
IF $$FMDIFF^XLFDT(DT,VDT)>3
SET EDIT=1001
GOTO OUT
+9 SET ASQM=$ORDER(^AUTTMSR("C",66,0))
SET Z=999999999
SET OLD=0
+10 ; CHECK TO SEE IF THERE IS ALREADY ASQ DATA FOR THIS VISIT
IF $GET(TVIEN)
FOR
SET Z=$ORDER(^AUPNVMSR("AD",TVIEN,Z),-1)
IF 'Z
QUIT
IF +$GET(^AUPNVMSR(Z,0))=ASQM
SET OLD=1
QUIT
+11 ; NO CURRENT ROW: NEW ROW ADDED + OLD DATA
IF 'OLD
DO T1(DFN,DATE,TVIEN,.TODAY,.START,.FIN)
SET EDIT=1003
GOTO OUT
+12 ; AT THIS POINT WE KNOW THERE IS ASQ DATA ASSOCIATED WITH THE CURRENT VISIT
+13 ; GET CURRENT ASQ
SET X=$ORDER(^AUPNVMSR("AA",DFN,+ASQM,0))
+14 ; CURRENT VISIT IS NOT THE MOST RECENT ASQ VISIT: CURRENT ROW IS LOCKED - ALLOW OLD DATA ONLY
IF ((9999999-X)\1)<VDT
SET EDIT=1001
GOTO OUT
+15 ; CURRENT ROW IS EDITABLE (CURRENT ROW IS PART OF OLD DATA SET)
SET EDIT=1004
OUT ; GET TABLE GEN STRING FOR THIS ASQ MEASUREMENT
SET OUT="BMX ADO SS^VEN ASQ TX^^~"_START_"~"_FIN_"~"_EDIT
+1 DO ^XBFMK
+2 ; THE VARIABLE 'TABLE' TELLS THE OBJECT WHAT CAN BE DONE: 1001=OLD VALUES ONLY,1002=NEW VALUE ONLY,1003=OLD AND 1 NEW ROW,1004=OLD WITH 1 EDITABLE ROW
+3 QUIT
+4 ;
T1(DFN,DATE,TVIEN,TODAY,START,FIN) ; BUILD NEW ROW
+1 SET TODAY=""
SET START=$GET(START)
SET FIN=$GET(FIN)
+2 IF $GET(DATE)
IF $GET(DFN)
+3 IF '$TEST
QUIT
+4 NEW X,Y,Z,%,DOB,EDOB,MOS2,ADOB,GA,ASQ2,FC2,GC2,CC2,SC2,DATE2,DIC,DIE,DA,DR,M,QIEN
+5 ; ADJUSTED (ASQ) AGE IN MOS
SET M=$$ASQAGE^VENPCCQ(DFN,DATE)
IF 'M
QUIT
+6 ; QUESTIONNAIRE IEN
SET QIEN=+$$ASQIEN^VENPCCQ(M)
IF 'QIEN
QUIT
+7 SET DOB=$PIECE($GET(^DPT(DFN,0)),U,3)
+8 ; PRINTED DOB
SET EDOB=$$FMTE^XLFDT(DOB,"2D")
+9 ; CHRONOLICAL AGE IN MONTHS
SET MOS2=$$DOBAGE^VENPCCQ(DFN,DATE)
+10 ; ADJUSTED (ASQ) DOB
SET ADOB=$$ASQDOB^VENPCCQ(DFN)
+11 IF ADOB
SET ADOB=$$FMTE^XLFDT(ADOB,"2D")
+12 ; GESTATIONAL AGE FROM BIRTH MEASUREMENT FILE
SET GA=$PIECE($GET(^AUPNBMSR(DFN,0)),U,6)
+13 SET %=$GET(^VEN(7.14,QIEN,0))
IF '$LENGTH(%)
QUIT
+14 ; QUESTIONNAIRE (MONTH)
SET ASQ2=$PIECE(%,U,1)
+15 ; FINE MOTOR CUTOFF
SET FC2="("_$PIECE(%,U,4)_")"
+16 ; GROSS MOTOR CUTOFF
SET GC2="("_$PIECE(%,U,3)_")"
+17 ; COMMUNICATION CUTOFF
SET CC2="("_$PIECE(%,U,2)_")"
+18 ; PERSONAL-SOCIAL CUTOFF
SET SC2="("_$PIECE(%,U,6)_")"
+19 ; PROBLEM SOLVING CUTOFF
SET PC2="("_$PIECE(%,U,5)_")"
+20 SET DATE2=$$FMTE^XLFDT(DATE,"2D")
+21 SET DIC="^VEN(7.15,"
SET DIC(0)="L"
SET DLAYGO=19707.15
SET X=""""_DFN_""""
+22 DO ^DIC
IF Y=-1
SET IEN=""
DO ^XBFMK
QUIT
+23 ; IEN IN THE ASQ TX FILE FOR TODAY'S NEW ENTRY
IF '$GET(START)
SET START=+Y
+24 SET (TODAY,FIN)=+Y
+25 SET ^VEN(7.15,+Y,0)=DFN_U_DATE2_U_ASQ2_U_MOS2_U_EDOB_U_ADOB_U_GA_U_TVIEN
+26 SET ^VEN(7.15,+Y,1)=U_FC2_U_"*"_U_GC2_U_"*"_U_CC2_U_"*"_U_SC2_U_"*"_U_PC2_U_"*"
+27 DO ^XBFMK
+28 QUIT
+29 ;
LSTG(DFN) ; EP - GET LAST ASQ VALUES
+1 ; DEAD CODE
+2 NEW LSTG,IDT,STOP,WCIEN,STG,PCE,V,C,X,Y,Z,%
+3 NEW F1,FC1,G1,GC1,C1,CC1,S1,SC1,P1,PS1,ASQIEN
+4 SET LSTG=""
+5 SET IDT=0
SET STOP=0
+6 FOR
SET IDT=$ORDER(^AUPNVWC("AA",DFN,IDT))
IF 'IDT
QUIT
Begin DoDot:1
+7 SET WCIEN=0
+8 FOR
SET WCIEN=$ORDER(^AUPNVWC("AA",DFN,IDT,WCIEN))
IF 'WCIEN
QUIT
Begin DoDot:2
+9 SET STG=$GET(^AUPNVWC(WCIEN,2))
IF '$PIECE(STG,U,7)
QUIT
+10 IF STG?1."^"
QUIT
+11 SET VIEN=$PIECE($GET(^AUPNVWC(WCIEN,0)),U,3)
IF 'VIEN
QUIT
+12 SET FMDT=+^AUPNVSIT(VIEN,0)\1
+13 ; DATE OF LAST ASQ
SET DATE1=$$FMTE^XLFDT(FMDT,2)
+14 ; MUST HAVE A VALID ASQ IEN
SET ASQIEN=$PIECE(STG,U,7)
IF 'ASQIEN
QUIT
+15 ; MUST HAVE A VALID QUESTIONNAIRE MONTH
SET ASQ1=+$GET(^VEN(7.14,ASQIEN,0))
IF 'ASQ1
QUIT
+16 ; GET AGE IN MOS AT LAST VISIT
SET MOS1=$$LASTAGE(DFN,FMDT)
+17 SET STOP=1
+18 FOR PCE=1:1:5
Begin DoDot:3
+19 SET %=$EXTRACT("FGCSP",PCE)
+20 SET V=%_1
SET C=%_"C1"
+21 SET X=$PIECE(STG,U,PCE)
SET Y=+X
SET Z=+$PIECE(X,"(",2)
+22 IF $PIECE(X," ")'=""
SET @V=Y
+23 IF Z
SET @C=Z
+24 QUIT
End DoDot:3
+25 QUIT
End DoDot:2
IF STOP
QUIT
+26 QUIT
End DoDot:1
IF STOP
QUIT
+27 SET LSTG=$GET(F1)_U_$GET(FC1)_U_$GET(G1)_U_$GET(GC1)_U_$GET(C1)_U_$GET(CC1)_U_$GET(S1)_U_$GET(SC1)_U_$GET(P1)_U_$GET(PC1)
+28 QUIT LSTG
+29 ;
LASTAGE(DFN,DT) ; EP - GET LAST AGE IN MONTHS
+1 QUIT $$DOBAGE^VENPCCQ(DFN)
+2 ;
FLUSH(OUT,IN) ; EP - RPC: VEN ASQ FLUSH
+1 ; FLUSH ASQ DATA OUT OF TX FILE INTO V FILES
+2 SET OUT=""
+3 NEW IEN,DIC,DIE,DA,DR,X,Y,Z,%,VIEN,VDT,XDT,TIEN,DFN,ASQ,F,FC,G,GC,C,CC,S,SC,P,PC,ASQIEN,NOW,PRVIEN
+4 NEW DATE,FMDT,%DT,PCE,STG,V1,V2,GBL,VSTG,VAL,ENT,PRVIEN,NOW,EDT,RDT,KALL,ROW
+5 SET IEN(1)=+$PIECE($GET(IN),"~",2)
SET IEN(2)=+$PIECE($GET(IN),"~",3)
SET IEN(3)=$PIECE($GET(IN),"~",4)
+6 IF IEN(3)
IF IEN(2)
IF IEN(1)
+7 IF '$TEST
QUIT
+8 SET ROW=$SELECT(IEN(3)=1003:IEN(2),1:IEN(1))
IF 'ROW
QUIT
+9 ; ,NOW=$E($$NOW^XLFDT,1,12)
SET TIEN=ROW
SET PRVIEN=+$PIECE($GET(IN),"~",5)
+10 SET DFN=+$GET(^VEN(7.15,ROW,0))
IF 'DFN
QUIT
+11 SET VIEN=$PIECE(^VEN(7.15,ROW,0),U,8)
IF 'VIEN
QUIT
+12 SET VDT=+$GET(^AUPNVSIT(VIEN,0))\1
IF 'VDT
QUIT
FL1 SET X=$GET(^VEN(7.15,TIEN,0))
+1 SET DFN=+X
SET ASQ=$PIECE(X,U,3)
SET DATE=$PIECE(X,U,2)
SET EDT=""
SET RDT=$GET(DT)
FL2 SET ASQIEN=$ORDER(^VEN(7.14,"B",+$GET(ASQ),0))
+1 ; ASQ FORM NOT DEFINED, SO DELETE ALL OF THE VISIT'S ASQ RESULTS AND QUIT
IF 'ASQIEN
DO ASQCLEAN(VIEN)
SET OUT="OK"
QUIT
+2 ; S X=DATE D ^%DT S FMDT=Y
+3 SET STG=$GET(^VEN(7.15,TIEN,1))
IF '$LENGTH(STG)
QUIT
+4 FOR PCE=1:1:5
Begin DoDot:1
+5 SET %=$EXTRACT("FGCSP",PCE)
+6 SET V1=%
SET V2=%_"C"
+7 IF PCE=1
SET X=$PIECE(STG,U,11)
SET Y=$PIECE(STG,U,2)
+8 IF '$TEST
SET Z=(PCE*2)-1
SET X=$PIECE(STG,U,Z)
SET Y=$PIECE(STG,U,Z+1)
+9 SET Y=$TRANSLATE(Y,"(","")
SET Y=$TRANSLATE(Y,")","")
+10 SET @V1=X
SET @V2=Y
+11 QUIT
End DoDot:1
+12 SET VSTG=F_" ("_FC_")^"_G_" ("_GC_")^"_C_" ("_CC_")^"_S_" ("_SC_")^"_P_" ("_PC_")^^"_ASQ
+13 IF $GET(NOWC)
GOTO MEAS
WC ; V WELL CHILD ENTRY
+1 ; GET V WELL CHILD RECORD NUMBER
SET DA=$$VWC(DFN,VIEN)
IF 'DA
GOTO MEAS
+2 SET GBL=$NAME(^AUPNVWC(DA,2))
+3 SET @GBL=VSTG
MEAS ; V MEASUREMENTS ENTRY
+1 SET KALL=0
SET DA=""
+2 FOR PCE=7,1:1:5
SET VAL=$PIECE(VSTG,U,PCE)
Begin DoDot:1
+3 ; KILL ALL ASQ MEASUREMENTS FOR THIS VISIT
IF PCE=7
IF +VAL=0
SET KALL=1
+4 ; MUST BE A LEGIT ASQ MONTH
IF '$TEST
IF PCE=7
IF $ORDER(^VEN(7.14,"B",+$GET(VAL),0))=""
SET KALL=1
+5 ; DELETE THE V MEASUREMENT ENTRY
IF +VAL=0!(KALL)
SET VAL="@"
+6 ; MAKE INDIVIDUAL V MEAS ENTRIES
DO ASQVMSR(PCE,VAL,VIEN,VDT,PRVIEN,EDT,RDT)
+7 QUIT
End DoDot:1
DEL SET DIK="^VEN(7.15,"
SET DA=""
+1 ; CLEAN UP THE TX FILE
FOR
SET DA=$ORDER(^VEN(7.15,"B",DFN,DA))
IF 'DA
QUIT
IF $DATA(^VEN(7.15,DA))
DO ^DIK
+2 SET OUT="OK"
+3 DO ^XBFMK
+4 QUIT
+5 ;
ASQCLEAN(VIEN) ; IF THERE IS NO ASQ MONTH VALUE, CLEAN OUT ALL ASQ RESULTS FOR THIS VISIT.
+1 IF VIEN
+2 IF '$TEST
QUIT
+3 NEW DIC,DIE,DA,DR,DIK,X,Y,Z,%,MVIEN,WREF
+4 SET DA=0
SET WREF="^AUPNVWC"
SET DIK="^AUPNVMSR("
+5 ; CLEAN OUT THE ASQ NODE (2) IN THE V WELL CHILD FILE
FOR
SET DA=$ORDER(^AUPNVWC("AD",VIEN,DA))
IF 'DA
QUIT
KILL @WREF@(DA,2)
+6 FOR
SET DA=$ORDER(^AUPNVMSR("AD",VIEN,DA))
IF 'DA
QUIT
Begin DoDot:1
+7 SET X=+$GET(^AUPNVMSR(DA,0))
IF 'X
QUIT
+8 SET Y=$PIECE($GET(^AUTTMSR(X,0)),U)
IF $EXTRACT(Y,1,3)'="ASQ"
QUIT
+9 DO ^DIK
+10 QUIT
End DoDot:1
+11 DO ^XBFMK
+12 QUIT
+13 ;
EHRFLUSH(OUT,IN) ; EP - VEN ASQ EHR FLUSH
+1 ; GIVEN THE PATIENT IEN, FLUSH TODAY'S ASQ RESULTS TO THE V MEASUREMENT FILE
+2 SET OUT=""
+3 IF $GET(IN)
IF $DATA(^AUPNVSIT(+IN,0))
+4 IF '$TEST
QUIT
+5 NEW DFN,VSTG,TIEN,X,Y,Z,%,VIEN,NOWC,ASQ,DATE,ASQIEN,STG,PCE,V1,V2,VSTG,VAL,DIK,DIC,DIE,DA,DR,VDT
+6 SET VIEN=+IN
+7 SET VDT=+$GET(^AUPNVSIT(VIEN,0))\1
IF 'VDT
QUIT
+8 SET DFN=$PIECE($GET(^AUPNVSIT(VIEN,0)),U,5)
IF 'DFN
QUIT
+9 SET TIEN=99999999
+10 ; FIND THE ROW ASSOCIATED WITH TODAY'S VISIT
FOR
SET TIEN=$ORDER(^VEN(7.15,"B",DFN,TIEN),-1)
IF 'TIEN
QUIT
IF $PIECE($GET(^VEN(7.15,TIEN,0)),U,8)=VIEN
QUIT
+11 IF TIEN
SET NOWC=1
DO FL1
SET DA=TIEN
SET DIK="^VEN(7.15,"
DO ^DIK
DO ^XBFMK
+12 QUIT
+13 ;
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,VDT,GBL
+3 SET VDT=+$GET(^AUPNVSIT(VIEN,0))\1
IF 'VDT
QUIT ""
+4 ; A RECORD HAS ALREADY BEEN CREATED - GET LATEST V WC RECORD
SET DA=$ORDER(^AUPNVWC("AD",VIEN,999999999),-1)
IF DA
QUIT DA
+5 SET DIC="^AUPNVWC("
SET DIC(0)="L"
SET DLAYGO=9000010.46
SET X=""""_0_""""
+6 DO ^DIC
+7 IF Y=-1
QUIT ""
+8 SET GBL="^AUPNVWC"
+9 SET DA=+Y
SET DIE=DIC
SET DR=".02////^S X=DFN;.03////^S X=VIEN"
+10 LOCK +^AUPNVWC(DA):1
IF $TEST
DO ^DIE
LOCK -^AUPNVWC(DA)
+11 SET @GBL@("AC",DFN,DA)=""
SET @GBL@("AD",VIEN,DA)=""
SET @GBL@("AA",DFN,9999999-VDT,DA)=""
+12 QUIT DA
+13 ;
ASQVMSR(PCE,VAL,VIEN,VDT,PRVIEN,EDT,RDT) ; EP - FILE ASQ SCORES IN V MEASUREMNTS
+1 NEW DIE,DIC,DA,DR,X,Y
+2 SET DIE="^AUPNVMSR("
+3 SET X=$PIECE("ASQF^ASQG^ASQL^ASQS^ASQP^^ASQM",U,PCE)
IF X=""
QUIT
+4 ; FIND EXISTING V MEASUREMENT, OR MAKE A NEW ONE, OR KILL OLD ONE IF VAL="@"
SET DA=$$VMSR(VIEN,X,VAL)
IF 'DA
QUIT
+5 IF VAL="@"
QUIT
+6 SET DR=".04////^S X=VAL;.08////^S X=PRVIEN;1204////^S X=PRVIEN"
+7 IF $PIECE($GET(^AUPNVMSR(DA,0)),U,2)=""
SET DR=".02////^S X=DFN;.03////^S X=VIEN;"_DR
+8 IF '$GET(EDT)
SET EDT=$GET(VDT)\1
+9 IF $GET(EDT)
SET DR=DR_";1201////^S X=EDT"
+10 IF $GET(RDT)
SET DR=DR_";.07////^S X=RDT"
SETMSR LOCK +^AUPNVMSR(DA):1
IF $TEST
DO ^DIE
LOCK -^AUPNVMSR(DA)
+1 QUIT
+2 ;
VMSR(VIEN,TYPE,VAL) ; EP - FIND OR CREATE A V MEASUREMENT ENTRY
+1 NEW MIEN,VMIEN,DIC,X,Y,DIK,DA
+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 ; DELETE EXISTING ENTRY BECAUSE THERE IS NO VALUE
IF VMIEN
IF VAL="@"
SET DIK="^AUPNVMSR("
SET DA=VMIEN
DO ^DIK
KILL DIK,DA
+6 ; NO NEW V MED ENTRY BECAUSE VAL IS NULL
IF VAL="@"
QUIT ""
+7 ; A V MEAS ENTRY ALREADY EXISTS FOR THIS ASQ CATEGORY AND VISIT
IF VMIEN
QUIT VMIEN
+8 ; AT THIS POINT THERE IS NO EXISTING ENTRY BUT THERE IS A VALID VALUE, SO MAKE A NEW V MEAS ENTRY STUB
+9 SET DIC="^AUPNVMSR("
SET DIC(0)="L"
SET DLAYGO=9000010.01
+10 SET X=""""_TYPE_""""
+11 ; MAKE A NEW V MEAS ENTRY
DO ^DIC
IF Y=-1
QUIT ""
+12 QUIT +Y
+13 ;
MLSTG(DFN,TVIEN,LSTGX,LSTG1) ; EP - GET LAST ASQ VALUES
+1 SET LSTGX=""
SET LSTG1=""
+2 NEW IDT,STOP,STG,PCE,V,C,X,Y,Z,%,ASQIEN,VIEN
+3 NEW ASQA,ASQF,ASQG,ASQL,ASQM,ASQP,ASQS,I,STG,TYPE,RIEN,VMIEN,MSR,MTYP
+4 NEW F,FC,G,GC,L,LC,S,SC,P,PC,VAL,MIEN,ASQ1,MOS1,DATE1,FMDT,REDT,CUT,CP,FIEN,VARR,MOS
+5 SET STG="AFGLMPS"
+6 FOR I=1:1:$LENGTH(STG)
SET X=$EXTRACT(STG,I)
SET Y=$ORDER(^AUTTMSR("B",("ASQ"_X),0))
IF 'Y
QUIT
SET @("ASQ"_X)=Y
+7 ; THIS IS THE ONLY REQUIRED MEASUREMENT
IF '$GET(ASQM)
QUIT
+8 SET IDT=0
SET STOP=0
+9 ; BUILD VISIT ARRAY BASED ON THE EXISTANCE OF ASQM
FOR
SET IDT=$ORDER(^AUPNVMSR("AA",DFN,ASQM,IDT))
IF 'IDT
QUIT
Begin DoDot:1
+10 SET MIEN=9999999999
+11 FOR
SET MIEN=$ORDER(^AUPNVMSR("AA",DFN,ASQM,IDT,MIEN),-1)
IF 'MIEN
QUIT
Begin DoDot:2
+12 SET VIEN=$PIECE($GET(^AUPNVMSR(MIEN,0)),U,3)
IF 'VIEN
QUIT
+13 SET MOS=$PIECE(^AUPNVMSR(MIEN,0),U,4)
IF 'MOS
QUIT
+14 SET VARR(VIEN)=MOS
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 ; NOW GET ALL THE ASQ MEASUREMENTS FOR EACH VISIT
FOR RIEN=ASQM,ASQA,ASQF,ASQG,ASQL,ASQP,ASQS
Begin DoDot:1
+18 SET IDT=0
+19 SET MTYP=$PIECE($GET(^AUTTMSR(RIEN,0)),U)
IF MTYP=""
QUIT
+20 FOR
SET IDT=$ORDER(^AUPNVMSR("AA",DFN,RIEN,IDT))
IF 'IDT
QUIT
Begin DoDot:2
+21 SET MIEN=9999999999
+22 FOR
SET MIEN=$ORDER(^AUPNVMSR("AA",DFN,RIEN,IDT,MIEN),-1)
IF 'MIEN
QUIT
Begin DoDot:3
+23 SET VIEN=$PIECE($GET(^AUPNVMSR(MIEN,0)),U,3)
IF '$DATA(VARR(+VIEN))
QUIT
+24 SET VARR(VIEN,MIEN)=MTYP
+25 QUIT
End DoDot:3
+26 QUIT
End DoDot:2
+27 QUIT
End DoDot:1
SV SET VIEN=9999999999
FOR
SET VIEN=$ORDER(VARR(VIEN),-1)
IF 'VIEN
QUIT
Begin DoDot:1
+1 SET FMDT=+^AUPNVSIT(VIEN,0)\1
IF 'FMDT
QUIT
+2 ; FOR EACH VISIT PROCESSED, REFRESH ALL VALUES
SET (F,G,L,S,P)=""
+3 ; ASQ FROM (MOS) AND ASQ FORM IEN
SET MOS=VARR(VIEN)
SET FIEN=$ORDER(^VEN(7.14,"B",MOS,0))
IF 'FIEN
QUIT
+4 SET MIEN=0
FOR
SET MIEN=$ORDER(VARR(VIEN,MIEN))
IF 'MIEN
QUIT
Begin DoDot:2
+5 ; BYPASS ALL RESULTS ENTERED IN ERROR
IF $PIECE($GET(^AUPNVMSR(MIEN,2)),U)
QUIT
+6 ; EVENT DATE REPLACES VISIT DATE (IF AVAILABLE)
SET %=$PIECE($GET(^AUPNVMSR(MIEN,12)),U)
IF %
SET FMDT=%\1
+7 ; DATE OF LAST ASQ - EXTERNAL FORMAT
SET DATE1=$$FMTE^XLFDT(FMDT,2)
+8 ; GET AGE IN MOS AT LAST VISIT
SET MOS1=$$LASTAGE(DFN,FMDT)
+9 ; DATE RESULTS ENTERED
SET REDT=$PIECE($GET(^AUPNVMSR(MIEN,0)),U,7)
+10 SET MTYP=VARR(VIEN,MIEN)
+11 SET MSR=$EXTRACT(MTYP,4)
IF MSR=""
QUIT
+12 DO CUTOFF(MSR,FIEN)
+13 SET VAL=$PIECE($GET(^AUPNVMSR(MIEN,0)),U,4)
+14 SET @MSR=$PIECE(VAL," ")
+15 QUIT
End DoDot:2
+16 IF $LENGTH(LSTGX)
SET LSTGX=LSTGX_"|"
+17 SET LSTGX=LSTGX_DFN_U_$GET(DATE1)_U_MOS_U_$GET(MOS1)_U_$GET(EDOB)_U_$GET(ADOB)_U_$GET(GA)_U_VIEN
+18 IF $LENGTH(LSTG1)
SET LSTG1=LSTG1_"|"
+19 ; FOR CURRENT VISIT, MAKE SURE THAT THE CUTOFF SCORE IS ALWAYS DISPLAYED
IF VIEN=TVIEN
FOR MSR="F","G","L","P","S"
IF @MSR=""
DO CUTOFF(MSR,FIEN)
+20 SET LSTG1=LSTG1_U_$GET(FC)_U_$GET(G)_U_$GET(GC)_U_$GET(L)_U_$GET(LC)_U_$GET(S)_U_$GET(SC)_U_$GET(P)_U_$GET(PC)_U_$GET(F)
+21 QUIT
End DoDot:1
+22 QUIT
+23 ;
CUTOFF(MSR,FIEN) ; POPULATE THE CUTOFF SCORE ARRAY
+1 NEW CP,%
+2 SET CP=$SELECT(MSR="F":4,MSR="G":3,MSR="L":2,MSR="P":5,MSR="S":6,1:"")
+3 IF CP=""
QUIT
+4 ; FORM MOS
SET %=$PIECE($GET(^VEN(7.14,FIEN,0)),U,CP)
IF '%
QUIT
+5 ; THE CUTOFF VALUE IS A TEXT STRING - A NUMBER INSIDE PARENTHESES
SET @(MSR_"C")="("_%_")"
+6 QUIT
+7 ;
MPOP(DFN,LSTG0,LSTG1,START,FIN) ; GIVEN A PATIENT IEN AND ASQ RESULTS STRING, POPULATE THE ASQ TRANSACTION TABLE RETURNING THE STARTING IENS AKA LAST
+1 SET START=""
SET FIN=""
+2 IF $GET(DFN)
IF $GET(LSTG0)'=""
IF $GET(LSTG1)'=""
+3 IF '$TEST
QUIT
+4 NEW X,Y,Z,DIC,DLAYGO,STG,PCE,STG1,STG0,MAX
+5 SET DIC="^VEN(7.15,"
SET DIC(0)="LO"
SET DLAYGO=19707.15
SET MAX=$LENGTH(LSTG1,"|")
+6 FOR PCE=1:1:MAX
Begin DoDot:1
+7 SET STG0=$PIECE(LSTG0,"|",PCE)
IF STG0=""
QUIT
+8 SET STG1=$PIECE(LSTG1,"|",PCE)
IF STG1=""
QUIT
+9 SET X=""""_DFN_""""
+10 DO ^DIC
IF Y=-1
QUIT
+11 IF 'START
SET START=+Y
+12 SET ^VEN(7.15,+Y,0)=STG0
+13 SET ^VEN(7.15,+Y,1)=STG1
+14 SET FIN=+Y
+15 QUIT
End DoDot:1
+16 QUIT
+17 ;
