BQIPTRF ;PRXM/HC/ALA-Patient Referrals ; 23 Feb 2007 2:22 PM
;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
;
Q
;
REF(DATA,DFN,TMFRAME) ; EP -- BQI PATIENT REFERRALS
;
;Description - all the referrals that a patient has
;
;Input
; DFN - Patient internal entry number
; TMFRAME - Timeframe
;
NEW UID,II,HEADER,BN,ENDT,RFIEN,PTYP,RTYP,VEND,BGDT,BPCADAT,BPCDTA,BPCEDAT
NEW BPCIDAT,BPCPIEN,BPCPNAM,BPCPURP,BPCRNUM,BQIPAT,NTMP,FLDS,NM,TMP,VAL,RSTAT
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPTRF",UID))
K @DATA
;
S TMFRAME=$G(TMFRAME,""),ENDT=""
I TMFRAME'="" S ENDT=$$DATE^BQIUL1(TMFRAME)
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTRF D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S HEADER="I00010REF_IEN^T00013REF_NUMBER^T00080PURPOSE^T00035PROVIDER_NAME^I00010PROV_IEN^D00030INITIAL_DATE^D00030EXP_SERV_DATE^D00030ACT_SERV_DATE^"
S HEADER=HEADER_"T00030PAT_TYPE^T00030REF_TYPE^T00030VENDOR^T00003REF_STAT"
S @DATA@(II)=HEADER_$C(30)
;
S BGDT=$S(ENDT="":"",1:ENDT-.0001)
;
I $$PATCH^XPDUTL("BMC*4.0*4") D G DONE
. S FLDS=".02/E;1201/E;.06/E;.06/I;.01/I;1105/I;1106/I;.14/E;.04/E;.07/E;.15/I"
. S TMP=$NA(^TMP(UID)),BQIPAT(DFN)=""
. D API^BMCAPI1(.BQIPAT,BGDT,"",FLDS,TMP)
. S RFIEN=""
. F S RFIEN=$O(@TMP@(DFN,RFIEN)) Q:RFIEN="" D
.. S NM="",II=II+1,$P(@DATA@(II),U,1)=RFIEN
.. F S NM=$O(@TMP@(DFN,RFIEN,NM)) Q:NM="" D
... S NTMP=$Q(@TMP@(DFN,RFIEN,NM))
... I NTMP["E" S VAL=@NTMP
... I NTMP["I" S VAL=$$FMTE^BQIUL1(@NTMP)
... S $P(@DATA@(II),U,1+NM)=VAL
.. S @DATA@(II)=@DATA@(II)_$C(30)
. K @TMP
;
F S BGDT=$O(^BMCREF("AA",DFN,BGDT)) Q:BGDT="" D
. S RFIEN=""
. F S RFIEN=$O(^BMCREF("AA",DFN,BGDT,RFIEN)) Q:RFIEN="" D
.. S BPCRNUM=$$GET1^DIQ(90001,RFIEN_",",.02,"E")
.. S BPCPIEN=$$GET1^DIQ(90001,RFIEN_",",.06,"I")
.. S BPCPNAM=$$GET1^DIQ(90001,RFIEN_",",.06,"E")
.. I BPCPNAM="" S BPCPNAM="NO PROVIDER INDICATED"
.. S BPCIDAT=$$FMTE^BQIUL1($$GET1^DIQ(90001,RFIEN_",",.01,"I"))
.. S BPCPURP=$$GET1^DIQ(90001,RFIEN_",",1201,"E")
.. S PTYP=$$GET1^DIQ(90001,RFIEN_",",.14,"E")
.. S RSTAT=$$GET1^DIQ(90001,RFIEN_",",.15,"I")
.. S RTYP=$$GET1^DIQ(90001,RFIEN_",",.04,"E")
.. S VEND=$$GET1^DIQ(90001,RFIEN_",",.07,"E")
.. S BPCEDAT=$$FMTE^BQIUL1($$GET1^DIQ(90001,RFIEN_",",1105,"I"))
.. S BPCADAT=$$FMTE^BQIUL1($$GET1^DIQ(90001,RFIEN_",",1106,"I"))
.. S BPCDTA=RFIEN_U_BPCRNUM_U_BPCPURP_U_BPCPNAM_U_BPCPIEN_U_BPCIDAT_U_BPCEDAT_U_BPCADAT
.. S II=II+1,@DATA@(II)=BPCDTA_U_PTYP_U_RTYP_U_VEND_U_RSTAT_$C(30)
;
DONE ;
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
BQIPTRF ;PRXM/HC/ALA-Patient Referrals ; 23 Feb 2007 2:22 PM
+1 ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
+2 ;
+3 QUIT
+4 ;
REF(DATA,DFN,TMFRAME) ; EP -- BQI PATIENT REFERRALS
+1 ;
+2 ;Description - all the referrals that a patient has
+3 ;
+4 ;Input
+5 ; DFN - Patient internal entry number
+6 ; TMFRAME - Timeframe
+7 ;
+8 NEW UID,II,HEADER,BN,ENDT,RFIEN,PTYP,RTYP,VEND,BGDT,BPCADAT,BPCDTA,BPCEDAT
+9 NEW BPCIDAT,BPCPIEN,BPCPNAM,BPCPURP,BPCRNUM,BQIPAT,NTMP,FLDS,NM,TMP,VAL,RSTAT
+10 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+11 SET DATA=$NAME(^TMP("BQIPTRF",UID))
+12 KILL @DATA
+13 ;
+14 SET TMFRAME=$GET(TMFRAME,"")
SET ENDT=""
+15 IF TMFRAME'=""
SET ENDT=$$DATE^BQIUL1(TMFRAME)
+16 ;
+17 SET II=0
+18 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPTRF D UNWIND^%ZTER"
+19 ;
+20 SET HEADER="I00010REF_IEN^T00013REF_NUMBER^T00080PURPOSE^T00035PROVIDER_NAME^I00010PROV_IEN^D00030INITIAL_DATE^D00030EXP_SERV_DATE^D00030ACT_SERV_DATE^"
+21 SET HEADER=HEADER_"T00030PAT_TYPE^T00030REF_TYPE^T00030VENDOR^T00003REF_STAT"
+22 SET @DATA@(II)=HEADER_$CHAR(30)
+23 ;
+24 SET BGDT=$SELECT(ENDT="":"",1:ENDT-.0001)
+25 ;
+26 IF $$PATCH^XPDUTL("BMC*4.0*4")
Begin DoDot:1
+27 SET FLDS=".02/E;1201/E;.06/E;.06/I;.01/I;1105/I;1106/I;.14/E;.04/E;.07/E;.15/I"
+28 SET TMP=$NAME(^TMP(UID))
SET BQIPAT(DFN)=""
+29 DO API^BMCAPI1(.BQIPAT,BGDT,"",FLDS,TMP)
+30 SET RFIEN=""
+31 FOR
SET RFIEN=$ORDER(@TMP@(DFN,RFIEN))
IF RFIEN=""
QUIT
Begin DoDot:2
+32 SET NM=""
SET II=II+1
SET $PIECE(@DATA@(II),U,1)=RFIEN
+33 FOR
SET NM=$ORDER(@TMP@(DFN,RFIEN,NM))
IF NM=""
QUIT
Begin DoDot:3
+34 SET NTMP=$QUERY(@TMP@(DFN,RFIEN,NM))
+35 IF NTMP["E"
SET VAL=@NTMP
+36 IF NTMP["I"
SET VAL=$$FMTE^BQIUL1(@NTMP)
+37 SET $PIECE(@DATA@(II),U,1+NM)=VAL
End DoDot:3
+38 SET @DATA@(II)=@DATA@(II)_$CHAR(30)
End DoDot:2
+39 KILL @TMP
End DoDot:1
GOTO DONE
+40 ;
+41 FOR
SET BGDT=$ORDER(^BMCREF("AA",DFN,BGDT))
IF BGDT=""
QUIT
Begin DoDot:1
+42 SET RFIEN=""
+43 FOR
SET RFIEN=$ORDER(^BMCREF("AA",DFN,BGDT,RFIEN))
IF RFIEN=""
QUIT
Begin DoDot:2
+44 SET BPCRNUM=$$GET1^DIQ(90001,RFIEN_",",.02,"E")
+45 SET BPCPIEN=$$GET1^DIQ(90001,RFIEN_",",.06,"I")
+46 SET BPCPNAM=$$GET1^DIQ(90001,RFIEN_",",.06,"E")
+47 IF BPCPNAM=""
SET BPCPNAM="NO PROVIDER INDICATED"
+48 SET BPCIDAT=$$FMTE^BQIUL1($$GET1^DIQ(90001,RFIEN_",",.01,"I"))
+49 SET BPCPURP=$$GET1^DIQ(90001,RFIEN_",",1201,"E")
+50 SET PTYP=$$GET1^DIQ(90001,RFIEN_",",.14,"E")
+51 SET RSTAT=$$GET1^DIQ(90001,RFIEN_",",.15,"I")
+52 SET RTYP=$$GET1^DIQ(90001,RFIEN_",",.04,"E")
+53 SET VEND=$$GET1^DIQ(90001,RFIEN_",",.07,"E")
+54 SET BPCEDAT=$$FMTE^BQIUL1($$GET1^DIQ(90001,RFIEN_",",1105,"I"))
+55 SET BPCADAT=$$FMTE^BQIUL1($$GET1^DIQ(90001,RFIEN_",",1106,"I"))
+56 SET BPCDTA=RFIEN_U_BPCRNUM_U_BPCPURP_U_BPCPNAM_U_BPCPIEN_U_BPCIDAT_U_BPCEDAT_U_BPCADAT
+57 SET II=II+1
SET @DATA@(II)=BPCDTA_U_PTYP_U_RTYP_U_VEND_U_RSTAT_$CHAR(30)
End DoDot:2
End DoDot:1
+58 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
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
