Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BQIPTPRC

BQIPTPRC.m

Go to the documentation of this file. 
  1. BQIPTPRC ;PRXM/HC/ALA - PATIENT ICD9 PROCEDURES ; 26 Mar 2007  5:15 PM
  1.  ;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41
  1.  ;
  1.  Q
  1.  ;
  1. PR(DATA,DFN,DRANGE) ; EP -- BQI PATIENT PROCEDURES
  1.  ;
  1.  ;Description - all the procedures that a patient has
  1.  ;
  1.  ;Input
  1.  ;  DFN - Patient internal entry number
  1.  ;
  1.  NEW UID,II,IEN,VISIT,VSDTM,PRCN,OPPRC,PRCC,DXC,PRDTM,PRPRC,INFC,OPPHY,CPT
  1.  NEW ORPHY,ENPHY,PRNAR,PNARR
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQIPTPRC",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTPRC D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S DRANGE=$$DATE^BQIUL1($G(DRANGE))
  1.  S @DATA@(II)="D00030VISIT_DATETIME^I00010VISIT_IEN^I00010PRC_IEN^T00060OPPROC_CODE^T00080PROV_NARR"_$C(30)
  1.  S IEN=""
  1.  F  S IEN=$O(^AUPNVPRC("AC",DFN,IEN),-1) Q:IEN=""  D
  1.  . S PRCN=$$GET1^DIQ(9000010.08,IEN_",",.01,"I") I PRCN="" Q
  1.  . S VISIT=$$GET1^DIQ(9000010.08,IEN_",",.03,"I") I VISIT="" Q
  1.  . S VSDTM=$$GET1^DIQ(9000010,VISIT_",",.01,"I") I VSDTM=0 Q
  1.  . I DRANGE'="",(VSDTM\1<DRANGE) Q
  1.  . I $$VERSION^XPDUTL("BCSV") D  ;csv
  1.  .. S OPPRC=$$ICD0^BQIUL3(PRCN,VSDTM\1,5) ; Code set versioning
  1.  .. S PRCC=$$ICD0^BQIUL3(PRCN,VSDTM\1,2) ; Code set versioning
  1.  . I '$$VERSION^XPDUTL("BCSV") D
  1.  .. S OPPRC=$$GET1^DIQ(80.1,PRCN_",",4,"E")
  1.  .. S PRCC=$$GET1^DIQ(80.1,PRCN_",",.01,"E")
  1.  . S DXC=$$GET1^DIQ(9000010.08,IEN_",",.05,"E")
  1.  . S PRDTM=$$GET1^DIQ(9000010.08,IEN_",",.06,"I")
  1.  . S PRPRC=$$GET1^DIQ(9000010.08,IEN_",",.07,"I")
  1.  . S INFC=$$GET1^DIQ(9000010.08,IEN_",",.08,"I")
  1.  . S OPPHY=$$GET1^DIQ(9000010.08,IEN_",",.11,"E")
  1.  . S CPT=$$GET1^DIQ(9000010.08,IEN_",",.16,"E")
  1.  . S ORPHY=$$GET1^DIQ(9000010.08,IEN_",",1202,"E")
  1.  . S ENPHY=$$GET1^DIQ(9000010.08,IEN_",",1204,"E")
  1.  . S PRNAR=$$GET1^DIQ(9000010.08,IEN_",",.019,"E")
  1.  . S NIEN=$$GET1^DIQ(9000010.08,IEN_",",.04,"I")
  1.  . S PNARR=PRNAR
  1.  . I $$PATCH^XPDUTL("BJPC*2.0*10") S PNARR=$$PNPROB^AUPNVUTL(NIEN)
  1.  . S II=II+1,@DATA@(II)=$$FMTE^BQIUL1(VSDTM)_U_VISIT_U_IEN_U_PRCC_"-"_OPPRC_U_PNARR_$C(30)
  1.  ;
  1.  ; Check for refusals
  1.  D REF
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. ERR ;
  1.  D ^%ZTER
  1.  NEW Y,ERRDTM
  1.  S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
  1.  S BMXSEC="Recording that an error occurred at "_ERRDTM
  1.  I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. REF ; Check for refusals
  1.  NEW PRCN,RVDT,REVDT,RFIEN,VISIT,PRCC,IEN,PRNAR
  1.  S PRCN=""
  1.  F  S PRCN=$O(^AUPNPREF("AA",DFN,80.1,PRCN)) Q:PRCN=""  D
  1.  . S RVDT=""
  1.  . F  S RVDT=$O(^AUPNPREF("AA",DFN,80.1,PRCN,RVDT)) Q:RVDT=""  D
  1.  .. ; Reverse the reverse date
  1.  .. S REVDT=9999999-RVDT
  1.  .. I DRANGE'="",(REVDT\1)<DRANGE Q
  1.  .. S RFIEN=""
  1.  .. F  S RFIEN=$O(^AUPNPREF("AA",DFN,80.1,PRCN,RVDT,RFIEN)) Q:RFIEN=""  D
  1.  ... I $$VERSION^XPDUTL("BCSV") D  ;csv
  1.  .... S PRCC=$$ICD0^BQIUL3(PRCN,REVDT\1,2) ; Code set versioning)
  1.  .... S PRNAR=$$ICD0^BQIUL3(PRCN,REVDT\1,5) ; Code set versioning
  1.  ... I '$$VERSION^XPDUTL("BCSV") D  ;csv
  1.  .... S PRCC=$$GET1^DIQ(80.1,PRCN_",",.01,"E")
  1.  .... S PRNAR=$$GET1^DIQ(80.1,PRCN_",",4,"E")
  1.  ... S RESULT=$$GET1^DIQ(9000022,RFIEN_",",.07,"E")
  1.  ... S ORPHY=$$GET1^DIQ(9000022,RFIEN_",",1204,"E")
  1.  ... S VISIT="",IEN=""
  1.  ... S II=II+1,@DATA@(II)=$$FMTE^BQIUL1(REVDT)_U_VISIT_U_IEN_U_PRCC_"-"_OPPRC_U_RESULT_$C(30)
  1.  Q