BQIPTDX ;PRXM/HC/ALA-Patient Diagnosis Categories ; 18 May 2006 10:14 AM
;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
;
Q
;
GET(DATA,DFN) ; EP -- BQI PAT DX CAT
;
;Description
; Returns a list of all of the Diagnosis Categories for a patient
;Input
; DFN - Patient internal entry number
;
NEW UID,II,DTMU,DXN,FN,NAME,FNAME,REC,CT,RECORD,RDATE,TAGDTU,WHO,COM
NEW RTYP,X,DXC,BNAME,COMPIEN,COMPREF,COMPVAL,FTNAME,TSTAT,SIEN,SCOM
NEW OCN,RIEN,BQVAL,OCOM,FREF,IEN
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPTDX",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTDX D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
D HDR
;
S DXN=""
F S DXN=$O(^BQIREG("C",DFN,DXN)) Q:DXN="" D
. S NAME=$$GET1^DIQ(90506.2,DXN_",",.01,"E")
. S SIEN=$O(^BQIREG("C",DFN,DXN,"")) I SIEN="" Q
. S TAGDTU=$P(^BQIREG(SIEN,0),U,4)
. S TAGDTU=$$FMTE^BQIUL1(TAGDTU)
. S WHO=$P(^BQIREG(SIEN,0),U,5)
. S TSTAT=$P(^BQIREG(SIEN,0),U,3)
. S SCOM=$$GET1^DIQ(90509,SIEN_",",.06,"I")
. S OCOM=""
. S OCN=0
. F S OCN=$O(^BQIREG(SIEN,1,OCN)) Q:'OCN D
.. S OCOM=OCOM_^BQIREG(SIEN,1,OCN,0)_" "
. ;
. S RIEN=""
. F S RIEN=$O(^BQIREG("C",DFN,DXN,RIEN)) Q:RIEN="" D
.. ;D RDATA(.DXN,.RIEN)
.. S BQVAL=$$RDATA(DXN,RIEN)
.. ;I $O(^BQIPAT(DFN,20,DXN,0))'="" D GDATA(.DXN)
.. I 'BQVAL S BQVAL=$$GDATA(DXN)
.. I 'BQVAL D
... S II=II+1
... S @DATA@(II)=DXN_U_U_U_U_U_U_U_TSTAT_U
... S @DATA@(II)=@DATA@(II)_TAGDTU_U_WHO_U_SCOM_U_OCOM_$C(30)
;
S II=II+1,@DATA@(II)=$C(31)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
Q
;
GDATA(DXN) ;EP - Get patient's data by diagnosis category
NEW BQRES,LII,STAT
S FN=0,BQRES=0
F S FN=$O(^BQIPAT(DFN,20,DXN,1,FN)) Q:'FN D
. S DTMU=$P(^BQIPAT(DFN,20,DXN,0),U,2)
. S FNAME=$P(^BQIPAT(DFN,20,DXN,1,FN,0),U,1)
. S SIEN=$O(^BQIREG("C",DFN,DXN,"")) I SIEN="" Q
. S STAT=$P(^BQIREG(SIEN,0),U,3)
. I STAT'="A",STAT'="P" Q
. ;
. ; If the met criteria is a tag, get the original data to display
. I FNAME[" Tag" S FTNAME=FNAME D TGG Q
. ;
. S REC="A",CT=0
. I '$O(^BQIPAT(DFN,20,DXN,1,FN,1,REC),-1) D
.. S II=II+1
.. S @DATA@(II)=DXN_"^"_$$FMTE^BQIUL1(DTMU)_"^"_FNAME_"^^"_$C(30)
. F S REC=$O(^BQIPAT(DFN,20,DXN,1,FN,1,REC),-1) Q:'REC!(CT>3) D
.. S CT=CT+1 Q:CT>3
.. ;
.. S COMPVAL=""
.. S RECORD=$P(^BQIPAT(DFN,20,DXN,1,FN,1,REC,0),U,1),RDATE=$P(^(0),U,2)
.. S COMPIEN=$P(^BQIPAT(DFN,20,DXN,1,FN,1,REC,0),U,4)
.. S FREF=$P(^BQIPAT(DFN,20,DXN,1,FN,1,REC,0),U,5)
.. I FREF'="" D
... S COMPREF=$P(^DD(FREF,.01,0),U,1)
... S COMPVAL=COMPREF_": "_$$GET1^DIQ(FREF,COMPIEN_",",.01,"E")
.. I $E(RECORD,1,1)="P" S COMPVAL="Problem: "_$$GET1^DIQ(9000011,$E(RECORD,2,$L(RECORD))_",",.01,"E")
.. S RTYP=$S($E(RECORD,1,1)="P":"Problem",1:"Visit")
.. I RDATE="" D
... NEW IEN
... S IEN=$E(RECORD,2,$L(RECORD))
... I $E(RTYP,1,1)="P" S RDATE=$$PROB^BQIUL1(IEN)
... I $E(RTYP,1,1)="V" S RDATE=$$GET1^DIQ(9000010,IEN_",",.01,"I")
.. S II=II+1,BQRES=1
.. S @DATA@(II)=DXN_U_$$FMTE^BQIUL1(DTMU)_U_FNAME_U_RTYP_U_COMPVAL_U_RECORD_U_$$FMTE^BQIUL1(RDATE)_U
.. S @DATA@(II)=@DATA@(II)_STAT_U_TAGDTU_U_WHO_U_SCOM_U_OCOM_$C(30)
Q BQRES
;
RDATA(DXN,BRIEN) ;EP
NEW BQRES,STAT
S BQRES=0
S STAT=$P(^BQIREG(BRIEN,0),U,3)
I STAT="P" D Q BQRES
. S FN=0
. F S FN=$O(^BQIREG(BRIEN,5,FN)) Q:'FN D
.. D FAC(FN,.BQRES)
;
S IEN=""
F S IEN=$O(^BQIFACT("C",DFN,DXN,IEN)) Q:IEN="" D FAC(IEN,.BQRES)
Q BQRES
;
TGG ; If the met criteria is a tag, get the original data to display
NEW FNAME,DXNN,RIEN
I FTNAME["-" S FTNAME=$P(FTNAME,"-",2)
S FTNAME=$P(FTNAME," Tag",1)
S DXNN=$$GDXN^BQITUTL(FTNAME),LII=II,BNAME=NAME
S RIEN=""
F S RIEN=$O(^BQIREG("C",DFN,DXNN,RIEN)) Q:RIEN="" D
. D RDATA(.DXNN,.RIEN)
. I $O(^BQIPAT(DFN,20,DXNN,0))'="" D GDATA(.DXNN)
;I $D(^BQIPAT(DFN,20,DXNN)) D GDATA(DXNN)
;I $D(^BQIREG("C",DFN,DXNN)) D RDATA(DXNN)
F S LII=$O(@DATA@(LII)) Q:LII="" S $P(@DATA@(LII),U,1)=DXN
Q
;
HDR ; Set up header
S @DATA@(II)="I00010DIAG_CAT_IEN^D00030CAT_LAST_UPDATED^T00060FACTOR^T00030PROBVISIT^T00030COMPLIANCE_VALUE^"
S @DATA@(II)=@DATA@(II)_"T00020PROB_VISIT_IEN^D00030VISIT_DATETIME^T00015STATUS^D00030STATUS_LASTUPDATE^"
S @DATA@(II)=@DATA@(II)_"T00035UPDATED_BY^T00050COMMENT^T01024OTHER_COMMENT"_$C(30)
Q
;
FAC(FIEN,BQRES) ; EP - Get factor data
NEW FDATA,FNAME,DTMU,COMPVAL,RDATE,COMPIEN,FREF,RECORD,COMPREF,COMPVAL
NEW COMPIEN,RTYP,RECORD
S FDATA=^BQIFACT(FIEN,0)
S FNAME=$P(FDATA,U,1)
;I FNAME[" Tag" S FTNAME=FNAME D TGG Q
I FNAME["Age:" S RTYP=""
;
;S DTMU=$P(FDATA,U,4)\1
S DTMU=$P(FDATA,U,4)
S COMPVAL=""
S RDATE=$P(FDATA,U,6)
S COMPIEN=$P(FDATA,U,5),FREF=$P(FDATA,U,8),RECORD=$P(FDATA,U,7)
I FREF'="" D
. S COMPREF=$P(^DD(FREF,.01,0),U,1)
. S COMPVAL=COMPREF_": "_$$GET1^DIQ(FREF,RECORD_",",.01,"E")
I $P(COMPIEN,";",2)="AUPNPROB(" S COMPVAL="Problem: "_$$GET1^DIQ(9000011,$P(COMPIEN,";",1)_",",.01,"E"),RTYP="Problem"
I $P(COMPIEN,";",2)="AUPNVSIT(" S RTYP="Visit"
;
I RDATE="" D
. NEW IEN
. S IEN=$P(COMPIEN,";",1)
. I $E(RTYP,1,1)="P" S RDATE=$$PROB^BQIUL1(IEN)
. I $E(RTYP,1,1)="V" S RDATE=$$GET1^DIQ(9000010,IEN_",",.01,"I")
S RECORD=$E(RTYP,1,1)_$P(COMPIEN,";",1)
S II=II+1
S @DATA@(II)=DXN_U_$$FMTE^BQIUL1(DTMU)_U_FNAME_U_RTYP_U_COMPVAL_U_RECORD_U_$$FMTE^BQIUL1(RDATE)_U_STAT_U
S @DATA@(II)=@DATA@(II)_TAGDTU_U_WHO_U_SCOM_U_OCOM_$C(30)
S BQRES=1
Q
;
FACD(FIEN,FPARMS) ;EP - Get factor data
K FPARMS
NEW FNAME,RTYP,FDATA,DTMU,COMPVAL,RDATE,COMPIEN,FREF,RECORD,COMPVAL
NEW COMPREF
S FDATA=^BQIFACT(FIEN,0)
S FNAME=$P(FDATA,U,1)
I FNAME["Age:" S RTYP=""
;
;S DTMU=$P(FDATA,U,4)\1
S DTMU=$P(FDATA,U,4)
S COMPVAL=""
S RDATE=$P(FDATA,U,6)
S COMPIEN=$P(FDATA,U,5),FREF=$P(FDATA,U,8),RECORD=$P(FDATA,U,7)
I FREF'="" D
. S COMPREF=$P(^DD(FREF,.01,0),U,1)
. S COMPVAL=COMPREF_": "_$$GET1^DIQ(FREF,RECORD_",",.01,"E")
I $P(COMPIEN,";",2)="AUPNPROB(" S COMPVAL="Problem: "_$$GET1^DIQ(9000011,$P(COMPIEN,";",1)_",",.01,"E"),RTYP="Problem"
I $P(COMPIEN,";",2)="AUPNVSIT(" S RTYP="Visit"
;
I RDATE="" D
. NEW IEN
. S IEN=$P(COMPIEN,";",1)
. I $E(RTYP,1,1)="P" S RDATE=$$PROB^BQIUL1(IEN)
. I $E(RTYP,1,1)="V" S RDATE=$$GET1^DIQ(9000010,IEN_",",.01,"I")
S RECORD=$E(RTYP,1,1)_$P(COMPIEN,";",1)
S FPARMS(1)=FNAME,FPARMS(2)=RTYP,FPARMS(3)=COMPVAL,FPARMS(4)=RECORD,FPARMS(5)=$$FMTE^BQIUL1(RDATE)
Q
;
FPD(BQIDFN,BQITAG,FPARMS) ;EP - Get proposed factor data
K FPARMS
NEW BQIFN,BQIFAC,BQIRN,BQIREC,BQIRDT,BQIREX,BQIIEN,COMPVAL,RTYP,BQIFIL
NEW COMPREF,BQIVPR
S BQIFN=0
F S BQIFN=$O(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN)) Q:'BQIFN D
. S BQIFAC=$P(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,0),U,1)
. I BQIFAC["Age:" S BQIVPR=""
. S BQIRN=0
. F S BQIRN=$O(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,1,BQIRN)) Q:'BQIRN D
.. S BQIREC=$P(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,1,BQIRN,0),U,1)
.. S BQIRDT=$P(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,1,BQIRN,0),U,2)
.. S BQIREX=$P(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,1,BQIRN,0),U,3)
.. S BQIIEN=$P(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,1,BQIRN,0),U,4)
.. S BQIFIL=$P(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,1,BQIRN,0),U,5)
.. S COMPVAL=""
.. S RTYP=$S($E(BQIREC,1,1)="V":"Visit",1:"Problem")
.. S COMPVAL="Problem: "_$$GET1^DIQ(9000011,$E(BQIREC,2,$L(BQIREC))_",",.01,"E")
.. I BQIFIL'="" D
... S COMPREF=$P(^DD(BQIFIL,.01,0),U,1)
... S COMPVAL=COMPREF_": "_$$GET1^DIQ(BQIFIL,BQIIEN_",",.01,"E")
.. S FPARMS(BQIFN_BQIRN,1)=BQIFAC,FPARMS(BQIFN_BQIRN,2)=RTYP,FPARMS(BQIFN_BQIRN,3)=COMPVAL
.. S FPARMS(BQIFN_BQIRN,4)=BQIREC,FPARMS(BQIFN_BQIRN,5)=$$FMTE^BQIUL1(BQIRDT)
Q
BQIPTDX ;PRXM/HC/ALA-Patient Diagnosis Categories ; 18 May 2006 10:14 AM
+1 ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
+2 ;
+3 QUIT
+4 ;
GET(DATA,DFN) ; EP -- BQI PAT DX CAT
+1 ;
+2 ;Description
+3 ; Returns a list of all of the Diagnosis Categories for a patient
+4 ;Input
+5 ; DFN - Patient internal entry number
+6 ;
+7 NEW UID,II,DTMU,DXN,FN,NAME,FNAME,REC,CT,RECORD,RDATE,TAGDTU,WHO,COM
+8 NEW RTYP,X,DXC,BNAME,COMPIEN,COMPREF,COMPVAL,FTNAME,TSTAT,SIEN,SCOM
+9 NEW OCN,RIEN,BQVAL,OCOM,FREF,IEN
+10 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+11 SET DATA=$NAME(^TMP("BQIPTDX",UID))
+12 KILL @DATA
+13 ;
+14 SET II=0
+15 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPTDX D UNWIND^%ZTER"
+16 ;
+17 DO HDR
+18 ;
+19 SET DXN=""
+20 FOR
SET DXN=$ORDER(^BQIREG("C",DFN,DXN))
IF DXN=""
QUIT
Begin DoDot:1
+21 SET NAME=$$GET1^DIQ(90506.2,DXN_",",.01,"E")
+22 SET SIEN=$ORDER(^BQIREG("C",DFN,DXN,""))
IF SIEN=""
QUIT
+23 SET TAGDTU=$PIECE(^BQIREG(SIEN,0),U,4)
+24 SET TAGDTU=$$FMTE^BQIUL1(TAGDTU)
+25 SET WHO=$PIECE(^BQIREG(SIEN,0),U,5)
+26 SET TSTAT=$PIECE(^BQIREG(SIEN,0),U,3)
+27 SET SCOM=$$GET1^DIQ(90509,SIEN_",",.06,"I")
+28 SET OCOM=""
+29 SET OCN=0
+30 FOR
SET OCN=$ORDER(^BQIREG(SIEN,1,OCN))
IF 'OCN
QUIT
Begin DoDot:2
+31 SET OCOM=OCOM_^BQIREG(SIEN,1,OCN,0)_" "
End DoDot:2
+32 ;
+33 SET RIEN=""
+34 FOR
SET RIEN=$ORDER(^BQIREG("C",DFN,DXN,RIEN))
IF RIEN=""
QUIT
Begin DoDot:2
+35 ;D RDATA(.DXN,.RIEN)
+36 SET BQVAL=$$RDATA(DXN,RIEN)
+37 ;I $O(^BQIPAT(DFN,20,DXN,0))'="" D GDATA(.DXN)
+38 IF 'BQVAL
SET BQVAL=$$GDATA(DXN)
+39 IF 'BQVAL
Begin DoDot:3
+40 SET II=II+1
+41 SET @DATA@(II)=DXN_U_U_U_U_U_U_U_TSTAT_U
+42 SET @DATA@(II)=@DATA@(II)_TAGDTU_U_WHO_U_SCOM_U_OCOM_$CHAR(30)
End DoDot:3
End DoDot:2
End DoDot:1
+43 ;
+44 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+45 QUIT
+46 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(II)
IF $DATA(DATA)
SET II=II+1
SET @DATA@(II)=$CHAR(31)
+6 QUIT
+7 ;
GDATA(DXN) ;EP - Get patient's data by diagnosis category
+1 NEW BQRES,LII,STAT
+2 SET FN=0
SET BQRES=0
+3 FOR
SET FN=$ORDER(^BQIPAT(DFN,20,DXN,1,FN))
IF 'FN
QUIT
Begin DoDot:1
+4 SET DTMU=$PIECE(^BQIPAT(DFN,20,DXN,0),U,2)
+5 SET FNAME=$PIECE(^BQIPAT(DFN,20,DXN,1,FN,0),U,1)
+6 SET SIEN=$ORDER(^BQIREG("C",DFN,DXN,""))
IF SIEN=""
QUIT
+7 SET STAT=$PIECE(^BQIREG(SIEN,0),U,3)
+8 IF STAT'="A"
IF STAT'="P"
QUIT
+9 ;
+10 ; If the met criteria is a tag, get the original data to display
+11 IF FNAME[" Tag"
SET FTNAME=FNAME
DO TGG
QUIT
+12 ;
+13 SET REC="A"
SET CT=0
+14 IF '$ORDER(^BQIPAT(DFN,20,DXN,1,FN,1,REC),-1)
Begin DoDot:2
+15 SET II=II+1
+16 SET @DATA@(II)=DXN_"^"_$$FMTE^BQIUL1(DTMU)_"^"_FNAME_"^^"_$CHAR(30)
End DoDot:2
+17 FOR
SET REC=$ORDER(^BQIPAT(DFN,20,DXN,1,FN,1,REC),-1)
IF 'REC!(CT>3)
QUIT
Begin DoDot:2
+18 SET CT=CT+1
IF CT>3
QUIT
+19 ;
+20 SET COMPVAL=""
+21 SET RECORD=$PIECE(^BQIPAT(DFN,20,DXN,1,FN,1,REC,0),U,1)
SET RDATE=$PIECE(^(0),U,2)
+22 SET COMPIEN=$PIECE(^BQIPAT(DFN,20,DXN,1,FN,1,REC,0),U,4)
+23 SET FREF=$PIECE(^BQIPAT(DFN,20,DXN,1,FN,1,REC,0),U,5)
+24 IF FREF'=""
Begin DoDot:3
+25 SET COMPREF=$PIECE(^DD(FREF,.01,0),U,1)
+26 SET COMPVAL=COMPREF_": "_$$GET1^DIQ(FREF,COMPIEN_",",.01,"E")
End DoDot:3
+27 IF $EXTRACT(RECORD,1,1)="P"
SET COMPVAL="Problem: "_$$GET1^DIQ(9000011,$EXTRACT(RECORD,2,$LENGTH(RECORD))_",",.01,"E")
+28 SET RTYP=$SELECT($EXTRACT(RECORD,1,1)="P":"Problem",1:"Visit")
+29 IF RDATE=""
Begin DoDot:3
+30 NEW IEN
+31 SET IEN=$EXTRACT(RECORD,2,$LENGTH(RECORD))
+32 IF $EXTRACT(RTYP,1,1)="P"
SET RDATE=$$PROB^BQIUL1(IEN)
+33 IF $EXTRACT(RTYP,1,1)="V"
SET RDATE=$$GET1^DIQ(9000010,IEN_",",.01,"I")
End DoDot:3
+34 SET II=II+1
SET BQRES=1
+35 SET @DATA@(II)=DXN_U_$$FMTE^BQIUL1(DTMU)_U_FNAME_U_RTYP_U_COMPVAL_U_RECORD_U_$$FMTE^BQIUL1(RDATE)_U
+36 SET @DATA@(II)=@DATA@(II)_STAT_U_TAGDTU_U_WHO_U_SCOM_U_OCOM_$CHAR(30)
End DoDot:2
End DoDot:1
+37 QUIT BQRES
+38 ;
RDATA(DXN,BRIEN) ;EP
+1 NEW BQRES,STAT
+2 SET BQRES=0
+3 SET STAT=$PIECE(^BQIREG(BRIEN,0),U,3)
+4 IF STAT="P"
Begin DoDot:1
+5 SET FN=0
+6 FOR
SET FN=$ORDER(^BQIREG(BRIEN,5,FN))
IF 'FN
QUIT
Begin DoDot:2
+7 DO FAC(FN,.BQRES)
End DoDot:2
End DoDot:1
QUIT BQRES
+8 ;
+9 SET IEN=""
+10 FOR
SET IEN=$ORDER(^BQIFACT("C",DFN,DXN,IEN))
IF IEN=""
QUIT
DO FAC(IEN,.BQRES)
+11 QUIT BQRES
+12 ;
TGG ; If the met criteria is a tag, get the original data to display
+1 NEW FNAME,DXNN,RIEN
+2 IF FTNAME["-"
SET FTNAME=$PIECE(FTNAME,"-",2)
+3 SET FTNAME=$PIECE(FTNAME," Tag",1)
+4 SET DXNN=$$GDXN^BQITUTL(FTNAME)
SET LII=II
SET BNAME=NAME
+5 SET RIEN=""
+6 FOR
SET RIEN=$ORDER(^BQIREG("C",DFN,DXNN,RIEN))
IF RIEN=""
QUIT
Begin DoDot:1
+7 DO RDATA(.DXNN,.RIEN)
+8 IF $ORDER(^BQIPAT(DFN,20,DXNN,0))'=""
DO GDATA(.DXNN)
End DoDot:1
+9 ;I $D(^BQIPAT(DFN,20,DXNN)) D GDATA(DXNN)
+10 ;I $D(^BQIREG("C",DFN,DXNN)) D RDATA(DXNN)
+11 FOR
SET LII=$ORDER(@DATA@(LII))
IF LII=""
QUIT
SET $PIECE(@DATA@(LII),U,1)=DXN
+12 QUIT
+13 ;
HDR ; Set up header
+1 SET @DATA@(II)="I00010DIAG_CAT_IEN^D00030CAT_LAST_UPDATED^T00060FACTOR^T00030PROBVISIT^T00030COMPLIANCE_VALUE^"
+2 SET @DATA@(II)=@DATA@(II)_"T00020PROB_VISIT_IEN^D00030VISIT_DATETIME^T00015STATUS^D00030STATUS_LASTUPDATE^"
+3 SET @DATA@(II)=@DATA@(II)_"T00035UPDATED_BY^T00050COMMENT^T01024OTHER_COMMENT"_$CHAR(30)
+4 QUIT
+5 ;
FAC(FIEN,BQRES) ; EP - Get factor data
+1 NEW FDATA,FNAME,DTMU,COMPVAL,RDATE,COMPIEN,FREF,RECORD,COMPREF,COMPVAL
+2 NEW COMPIEN,RTYP,RECORD
+3 SET FDATA=^BQIFACT(FIEN,0)
+4 SET FNAME=$PIECE(FDATA,U,1)
+5 ;I FNAME[" Tag" S FTNAME=FNAME D TGG Q
+6 IF FNAME["Age:"
SET RTYP=""
+7 ;
+8 ;S DTMU=$P(FDATA,U,4)\1
+9 SET DTMU=$PIECE(FDATA,U,4)
+10 SET COMPVAL=""
+11 SET RDATE=$PIECE(FDATA,U,6)
+12 SET COMPIEN=$PIECE(FDATA,U,5)
SET FREF=$PIECE(FDATA,U,8)
SET RECORD=$PIECE(FDATA,U,7)
+13 IF FREF'=""
Begin DoDot:1
+14 SET COMPREF=$PIECE(^DD(FREF,.01,0),U,1)
+15 SET COMPVAL=COMPREF_": "_$$GET1^DIQ(FREF,RECORD_",",.01,"E")
End DoDot:1
+16 IF $PIECE(COMPIEN,";",2)="AUPNPROB("
SET COMPVAL="Problem: "_$$GET1^DIQ(9000011,$PIECE(COMPIEN,";",1)_",",.01,"E")
SET RTYP="Problem"
+17 IF $PIECE(COMPIEN,";",2)="AUPNVSIT("
SET RTYP="Visit"
+18 ;
+19 IF RDATE=""
Begin DoDot:1
+20 NEW IEN
+21 SET IEN=$PIECE(COMPIEN,";",1)
+22 IF $EXTRACT(RTYP,1,1)="P"
SET RDATE=$$PROB^BQIUL1(IEN)
+23 IF $EXTRACT(RTYP,1,1)="V"
SET RDATE=$$GET1^DIQ(9000010,IEN_",",.01,"I")
End DoDot:1
+24 SET RECORD=$EXTRACT(RTYP,1,1)_$PIECE(COMPIEN,";",1)
+25 SET II=II+1
+26 SET @DATA@(II)=DXN_U_$$FMTE^BQIUL1(DTMU)_U_FNAME_U_RTYP_U_COMPVAL_U_RECORD_U_$$FMTE^BQIUL1(RDATE)_U_STAT_U
+27 SET @DATA@(II)=@DATA@(II)_TAGDTU_U_WHO_U_SCOM_U_OCOM_$CHAR(30)
+28 SET BQRES=1
+29 QUIT
+30 ;
FACD(FIEN,FPARMS) ;EP - Get factor data
+1 KILL FPARMS
+2 NEW FNAME,RTYP,FDATA,DTMU,COMPVAL,RDATE,COMPIEN,FREF,RECORD,COMPVAL
+3 NEW COMPREF
+4 SET FDATA=^BQIFACT(FIEN,0)
+5 SET FNAME=$PIECE(FDATA,U,1)
+6 IF FNAME["Age:"
SET RTYP=""
+7 ;
+8 ;S DTMU=$P(FDATA,U,4)\1
+9 SET DTMU=$PIECE(FDATA,U,4)
+10 SET COMPVAL=""
+11 SET RDATE=$PIECE(FDATA,U,6)
+12 SET COMPIEN=$PIECE(FDATA,U,5)
SET FREF=$PIECE(FDATA,U,8)
SET RECORD=$PIECE(FDATA,U,7)
+13 IF FREF'=""
Begin DoDot:1
+14 SET COMPREF=$PIECE(^DD(FREF,.01,0),U,1)
+15 SET COMPVAL=COMPREF_": "_$$GET1^DIQ(FREF,RECORD_",",.01,"E")
End DoDot:1
+16 IF $PIECE(COMPIEN,";",2)="AUPNPROB("
SET COMPVAL="Problem: "_$$GET1^DIQ(9000011,$PIECE(COMPIEN,";",1)_",",.01,"E")
SET RTYP="Problem"
+17 IF $PIECE(COMPIEN,";",2)="AUPNVSIT("
SET RTYP="Visit"
+18 ;
+19 IF RDATE=""
Begin DoDot:1
+20 NEW IEN
+21 SET IEN=$PIECE(COMPIEN,";",1)
+22 IF $EXTRACT(RTYP,1,1)="P"
SET RDATE=$$PROB^BQIUL1(IEN)
+23 IF $EXTRACT(RTYP,1,1)="V"
SET RDATE=$$GET1^DIQ(9000010,IEN_",",.01,"I")
End DoDot:1
+24 SET RECORD=$EXTRACT(RTYP,1,1)_$PIECE(COMPIEN,";",1)
+25 SET FPARMS(1)=FNAME
SET FPARMS(2)=RTYP
SET FPARMS(3)=COMPVAL
SET FPARMS(4)=RECORD
SET FPARMS(5)=$$FMTE^BQIUL1(RDATE)
+26 QUIT
+27 ;
FPD(BQIDFN,BQITAG,FPARMS) ;EP - Get proposed factor data
+1 KILL FPARMS
+2 NEW BQIFN,BQIFAC,BQIRN,BQIREC,BQIRDT,BQIREX,BQIIEN,COMPVAL,RTYP,BQIFIL
+3 NEW COMPREF,BQIVPR
+4 SET BQIFN=0
+5 FOR
SET BQIFN=$ORDER(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN))
IF 'BQIFN
QUIT
Begin DoDot:1
+6 SET BQIFAC=$PIECE(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,0),U,1)
+7 IF BQIFAC["Age:"
SET BQIVPR=""
+8 SET BQIRN=0
+9 FOR
SET BQIRN=$ORDER(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,1,BQIRN))
IF 'BQIRN
QUIT
Begin DoDot:2
+10 SET BQIREC=$PIECE(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,1,BQIRN,0),U,1)
+11 SET BQIRDT=$PIECE(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,1,BQIRN,0),U,2)
+12 SET BQIREX=$PIECE(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,1,BQIRN,0),U,3)
+13 SET BQIIEN=$PIECE(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,1,BQIRN,0),U,4)
+14 SET BQIFIL=$PIECE(^BQIPAT(BQIDFN,20,BQITAG,1,BQIFN,1,BQIRN,0),U,5)
+15 SET COMPVAL=""
+16 SET RTYP=$SELECT($EXTRACT(BQIREC,1,1)="V":"Visit",1:"Problem")
+17 SET COMPVAL="Problem: "_$$GET1^DIQ(9000011,$EXTRACT(BQIREC,2,$LENGTH(BQIREC))_",",.01,"E")
+18 IF BQIFIL'=""
Begin DoDot:3
+19 SET COMPREF=$PIECE(^DD(BQIFIL,.01,0),U,1)
+20 SET COMPVAL=COMPREF_": "_$$GET1^DIQ(BQIFIL,BQIIEN_",",.01,"E")
End DoDot:3
+21 SET FPARMS(BQIFN_BQIRN,1)=BQIFAC
SET FPARMS(BQIFN_BQIRN,2)=RTYP
SET FPARMS(BQIFN_BQIRN,3)=COMPVAL
+22 SET FPARMS(BQIFN_BQIRN,4)=BQIREC
SET FPARMS(BQIFN_BQIRN,5)=$$FMTE^BQIUL1(BQIRDT)
End DoDot:2
End DoDot:1
+23 QUIT
