BQIPTPRC ;PRXM/HC/ALA - PATIENT ICD9 PROCEDURES ; 26 Mar 2007 5:15 PM
;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41
;
Q
;
PR(DATA,DFN,DRANGE) ; EP -- BQI PATIENT PROCEDURES
;
;Description - all the procedures that a patient has
;
;Input
; DFN - Patient internal entry number
;
NEW UID,II,IEN,VISIT,VSDTM,PRCN,OPPRC,PRCC,DXC,PRDTM,PRPRC,INFC,OPPHY,CPT
NEW ORPHY,ENPHY,PRNAR,PNARR
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPTPRC",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTPRC D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S DRANGE=$$DATE^BQIUL1($G(DRANGE))
S @DATA@(II)="D00030VISIT_DATETIME^I00010VISIT_IEN^I00010PRC_IEN^T00060OPPROC_CODE^T00080PROV_NARR"_$C(30)
S IEN=""
F S IEN=$O(^AUPNVPRC("AC",DFN,IEN),-1) Q:IEN="" D
. S PRCN=$$GET1^DIQ(9000010.08,IEN_",",.01,"I") I PRCN="" Q
. S VISIT=$$GET1^DIQ(9000010.08,IEN_",",.03,"I") I VISIT="" Q
. S VSDTM=$$GET1^DIQ(9000010,VISIT_",",.01,"I") I VSDTM=0 Q
. I DRANGE'="",(VSDTM\1<DRANGE) Q
. I $$VERSION^XPDUTL("BCSV") D ;csv
.. S OPPRC=$$ICD0^BQIUL3(PRCN,VSDTM\1,5) ; Code set versioning
.. S PRCC=$$ICD0^BQIUL3(PRCN,VSDTM\1,2) ; Code set versioning
. I '$$VERSION^XPDUTL("BCSV") D
.. S OPPRC=$$GET1^DIQ(80.1,PRCN_",",4,"E")
.. S PRCC=$$GET1^DIQ(80.1,PRCN_",",.01,"E")
. S DXC=$$GET1^DIQ(9000010.08,IEN_",",.05,"E")
. S PRDTM=$$GET1^DIQ(9000010.08,IEN_",",.06,"I")
. S PRPRC=$$GET1^DIQ(9000010.08,IEN_",",.07,"I")
. S INFC=$$GET1^DIQ(9000010.08,IEN_",",.08,"I")
. S OPPHY=$$GET1^DIQ(9000010.08,IEN_",",.11,"E")
. S CPT=$$GET1^DIQ(9000010.08,IEN_",",.16,"E")
. S ORPHY=$$GET1^DIQ(9000010.08,IEN_",",1202,"E")
. S ENPHY=$$GET1^DIQ(9000010.08,IEN_",",1204,"E")
. S PRNAR=$$GET1^DIQ(9000010.08,IEN_",",.019,"E")
. S NIEN=$$GET1^DIQ(9000010.08,IEN_",",.04,"I")
. S PNARR=PRNAR
. I $$PATCH^XPDUTL("BJPC*2.0*10") S PNARR=$$PNPROB^AUPNVUTL(NIEN)
. S II=II+1,@DATA@(II)=$$FMTE^BQIUL1(VSDTM)_U_VISIT_U_IEN_U_PRCC_"-"_OPPRC_U_PNARR_$C(30)
;
; Check for refusals
D REF
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
;
REF ; Check for refusals
NEW PRCN,RVDT,REVDT,RFIEN,VISIT,PRCC,IEN,PRNAR
S PRCN=""
F S PRCN=$O(^AUPNPREF("AA",DFN,80.1,PRCN)) Q:PRCN="" D
. S RVDT=""
. F S RVDT=$O(^AUPNPREF("AA",DFN,80.1,PRCN,RVDT)) Q:RVDT="" D
.. ; Reverse the reverse date
.. S REVDT=9999999-RVDT
.. I DRANGE'="",(REVDT\1)<DRANGE Q
.. S RFIEN=""
.. F S RFIEN=$O(^AUPNPREF("AA",DFN,80.1,PRCN,RVDT,RFIEN)) Q:RFIEN="" D
... I $$VERSION^XPDUTL("BCSV") D ;csv
.... S PRCC=$$ICD0^BQIUL3(PRCN,REVDT\1,2) ; Code set versioning)
.... S PRNAR=$$ICD0^BQIUL3(PRCN,REVDT\1,5) ; Code set versioning
... I '$$VERSION^XPDUTL("BCSV") D ;csv
.... S PRCC=$$GET1^DIQ(80.1,PRCN_",",.01,"E")
.... S PRNAR=$$GET1^DIQ(80.1,PRCN_",",4,"E")
... S RESULT=$$GET1^DIQ(9000022,RFIEN_",",.07,"E")
... S ORPHY=$$GET1^DIQ(9000022,RFIEN_",",1204,"E")
... S VISIT="",IEN=""
... S II=II+1,@DATA@(II)=$$FMTE^BQIUL1(REVDT)_U_VISIT_U_IEN_U_PRCC_"-"_OPPRC_U_RESULT_$C(30)
Q
BQIPTPRC ;PRXM/HC/ALA - PATIENT ICD9 PROCEDURES ; 26 Mar 2007 5:15 PM
+1 ;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41
+2 ;
+3 QUIT
+4 ;
PR(DATA,DFN,DRANGE) ; EP -- BQI PATIENT PROCEDURES
+1 ;
+2 ;Description - all the procedures that a patient has
+3 ;
+4 ;Input
+5 ; DFN - Patient internal entry number
+6 ;
+7 NEW UID,II,IEN,VISIT,VSDTM,PRCN,OPPRC,PRCC,DXC,PRDTM,PRPRC,INFC,OPPHY,CPT
+8 NEW ORPHY,ENPHY,PRNAR,PNARR
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+10 SET DATA=$NAME(^TMP("BQIPTPRC",UID))
+11 KILL @DATA
+12 ;
+13 SET II=0
+14 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPTPRC D UNWIND^%ZTER"
+15 ;
+16 SET DRANGE=$$DATE^BQIUL1($GET(DRANGE))
+17 SET @DATA@(II)="D00030VISIT_DATETIME^I00010VISIT_IEN^I00010PRC_IEN^T00060OPPROC_CODE^T00080PROV_NARR"_$CHAR(30)
+18 SET IEN=""
+19 FOR
SET IEN=$ORDER(^AUPNVPRC("AC",DFN,IEN),-1)
IF IEN=""
QUIT
Begin DoDot:1
+20 SET PRCN=$$GET1^DIQ(9000010.08,IEN_",",.01,"I")
IF PRCN=""
QUIT
+21 SET VISIT=$$GET1^DIQ(9000010.08,IEN_",",.03,"I")
IF VISIT=""
QUIT
+22 SET VSDTM=$$GET1^DIQ(9000010,VISIT_",",.01,"I")
IF VSDTM=0
QUIT
+23 IF DRANGE'=""
IF (VSDTM\1<DRANGE)
QUIT
+24 ;csv
IF $$VERSION^XPDUTL("BCSV")
Begin DoDot:2
+25 ; Code set versioning
SET OPPRC=$$ICD0^BQIUL3(PRCN,VSDTM\1,5)
+26 ; Code set versioning
SET PRCC=$$ICD0^BQIUL3(PRCN,VSDTM\1,2)
End DoDot:2
+27 IF '$$VERSION^XPDUTL("BCSV")
Begin DoDot:2
+28 SET OPPRC=$$GET1^DIQ(80.1,PRCN_",",4,"E")
+29 SET PRCC=$$GET1^DIQ(80.1,PRCN_",",.01,"E")
End DoDot:2
+30 SET DXC=$$GET1^DIQ(9000010.08,IEN_",",.05,"E")
+31 SET PRDTM=$$GET1^DIQ(9000010.08,IEN_",",.06,"I")
+32 SET PRPRC=$$GET1^DIQ(9000010.08,IEN_",",.07,"I")
+33 SET INFC=$$GET1^DIQ(9000010.08,IEN_",",.08,"I")
+34 SET OPPHY=$$GET1^DIQ(9000010.08,IEN_",",.11,"E")
+35 SET CPT=$$GET1^DIQ(9000010.08,IEN_",",.16,"E")
+36 SET ORPHY=$$GET1^DIQ(9000010.08,IEN_",",1202,"E")
+37 SET ENPHY=$$GET1^DIQ(9000010.08,IEN_",",1204,"E")
+38 SET PRNAR=$$GET1^DIQ(9000010.08,IEN_",",.019,"E")
+39 SET NIEN=$$GET1^DIQ(9000010.08,IEN_",",.04,"I")
+40 SET PNARR=PRNAR
+41 IF $$PATCH^XPDUTL("BJPC*2.0*10")
SET PNARR=$$PNPROB^AUPNVUTL(NIEN)
+42 SET II=II+1
SET @DATA@(II)=$$FMTE^BQIUL1(VSDTM)_U_VISIT_U_IEN_U_PRCC_"-"_OPPRC_U_PNARR_$CHAR(30)
End DoDot:1
+43 ;
+44 ; Check for refusals
+45 DO REF
+46 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+47 QUIT
+48 ;
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 ;
REF ; Check for refusals
+1 NEW PRCN,RVDT,REVDT,RFIEN,VISIT,PRCC,IEN,PRNAR
+2 SET PRCN=""
+3 FOR
SET PRCN=$ORDER(^AUPNPREF("AA",DFN,80.1,PRCN))
IF PRCN=""
QUIT
Begin DoDot:1
+4 SET RVDT=""
+5 FOR
SET RVDT=$ORDER(^AUPNPREF("AA",DFN,80.1,PRCN,RVDT))
IF RVDT=""
QUIT
Begin DoDot:2
+6 ; Reverse the reverse date
+7 SET REVDT=9999999-RVDT
+8 IF DRANGE'=""
IF (REVDT\1)<DRANGE
QUIT
+9 SET RFIEN=""
+10 FOR
SET RFIEN=$ORDER(^AUPNPREF("AA",DFN,80.1,PRCN,RVDT,RFIEN))
IF RFIEN=""
QUIT
Begin DoDot:3
+11 ;csv
IF $$VERSION^XPDUTL("BCSV")
Begin DoDot:4
+12 ; Code set versioning)
SET PRCC=$$ICD0^BQIUL3(PRCN,REVDT\1,2)
+13 ; Code set versioning
SET PRNAR=$$ICD0^BQIUL3(PRCN,REVDT\1,5)
End DoDot:4
+14 ;csv
IF '$$VERSION^XPDUTL("BCSV")
Begin DoDot:4
+15 SET PRCC=$$GET1^DIQ(80.1,PRCN_",",.01,"E")
+16 SET PRNAR=$$GET1^DIQ(80.1,PRCN_",",4,"E")
End DoDot:4
+17 SET RESULT=$$GET1^DIQ(9000022,RFIEN_",",.07,"E")
+18 SET ORPHY=$$GET1^DIQ(9000022,RFIEN_",",1204,"E")
+19 SET VISIT=""
SET IEN=""
+20 SET II=II+1
SET @DATA@(II)=$$FMTE^BQIUL1(REVDT)_U_VISIT_U_IEN_U_PRCC_"-"_OPPRC_U_RESULT_$CHAR(30)
End DoDot:3
End DoDot:2
End DoDot:1
+21 QUIT
