- 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
