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

BGPGP.m

Go to the documentation of this file. 
  1. BGPGP ; IHS/CMI/MAW - BGPG Patient Lookup 4/28/2009 12:43:21 PM ;
  1.  ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
  1.  ;;
  1.  ;
  1.  ;
  1.  ;
  1.  Q
  1. GETPAT(RETVAL,BGPSTR) ;EP -- return patient in ADO table
  1.  S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap
  1.  N BGPI,BGPERRR,BGPUIEN,P
  1.  S P="|"
  1.  K ^BGPTMP($J)
  1.  S RETVAL="^BGPTMP("_$J_")"
  1.  S BGPI=0
  1.  S BGPERRR=""
  1.  S ^BGPTMP($J,BGPI)="T00010IEN^T00030PATIENTNAME^T00015DOB^T00001SEX^T00007CHART^T00009SSN^T00010REG^T00030MORE^T00030DOD^T00010AGE^T00001MESSAGEFLAG^T02500MESSAGE"_$C(30)
  1.  S BGPDUZ2=$P(BGPSTR,P)
  1.  S BGPPAT=$P(BGPSTR,P,2)
  1.  S BGPMT=$P(BGPSTR,P,3)
  1.  I BGPMT="" S BGPMT=99999
  1.  S BGPNPAT=$P(BGPSTR,P,4)
  1.  I '$G(BGPDUZ2) S BGPDUZ2=DUZ(2)
  1.  ;I BGPNPAT]"" S BGPPAT=BGPNPAT  ;cmi/maw 3/12/09 for testing
  1.  I BGPMT="ALL" S BGPMT=9999999
  1.  S BGPMT=(BGPMT-1)
  1.  I BGPPAT?9N D
  1.  . S BGPPIEN=$$PATSSN(BGPPAT)
  1.  I BGPPAT?1.6N D
  1.  . S BGPPIEN=$$PATCHT(.BGPPIEN,BGPPAT)
  1.  I BGPPAT?1.2N1"/"1.2N1"/"4N D
  1.  . S X=BGPPAT D ^%DT S BGPPAT=Y
  1.  . S BGPPIEN=$$PATDOB(.BGPPIEN,BGPPAT)
  1.  I '$G(BGPPIEN) D PATNAM(.BGPPIEN,BGPPAT,BGPNPAT)
  1.  I $G(BGPPIEN),'$G(BGPPATS) D PATADO(.BGPPIEN)
  1.  S ^BGPTMP($J,BGPI+1)=$C(31)
  1.  K BGPPAT,BGPPIEN,BGPCNT,BGPDA,BGPIEN,BGPPATE,BGPNM,BGPDB,BGPSX,BGPCT,BGPSSN,BGPDOD,BGPMORE,BGPAGE,BGPCNTR,BGPDG,BGPDUZ2,BGPMT,BGPNAM
  1.  K BGPPATS,BGPNPAT,BGPPI,BGPUPD
  1.  Q
  1.  ;
  1. PATSSN(PAT) ;EP -- look up by ssn
  1.  S BGPPIEN=$O(^DPT("SSN",PAT,0))
  1.  S BGPPIEN(1)=BGPPIEN
  1.  Q $G(BGPPIEN)
  1.  ;
  1. PATCHT(BGPPIEN,PAT) ;EP -- lookup by chart
  1.  ;ihs/cmi/maw 2/2/2011 added fix for same patient with same chart in multiple divisions
  1.  N BGPCNT,BGPOEN
  1.  S BGPCNT=0,BGPPATE=0,BGPMCNT=0
  1.  S BGPDA=(PAT-1) F  S BGPDA=$O(^AUPNPAT("D",BGPDA)) Q:'BGPDA!(BGPDA>PAT)!(BGPCNT>BGPMT)  D
  1.  . S BGPIEN=0 F  S BGPIEN=$O(^AUPNPAT("D",BGPDA,BGPIEN)) Q:'BGPIEN  D
  1.  .. S BGPOEN=0 F  S BGPOEN=$O(^AUPNPAT("D",BGPDA,BGPIEN,BGPOEN)) Q:'BGPOEN!($G(BGPPIEN))  D
  1.  ... ;I $O(^AUPNPAT("D",BGPDA,BGPIEN,0))=BGPDUZ2 S BGPPIEN=BGPIEN
  1.  ... I BGPOEN=BGPDUZ2 S BGPPIEN=BGPIEN
  1.  ... Q:'$G(BGPPIEN)
  1.  ... S BGPCNT=BGPCNT+1
  1.  ... S:'$D(BGPPIEN(BGPCNT)) BGPPIEN(BGPCNT)=0
  1.  ... S BGPPIEN(BGPCNT)=BGPPIEN
  1.  Q $G(BGPPIEN)
  1.  ;
  1. PATDOB(BGPPATE,PAT) ;EP -- lookup by DOB
  1.  N BGPCNT
  1.  S BGPCNT=0,BGPPATE=0
  1.  S BGPDOB=PAT-1 F  S BGPDOB=$O(^DPT("ADOB",BGPDOB)) Q:'BGPDOB!(BGPDOB'=+PAT)!(BGPCNT>BGPMT)  D
  1.  . S BGPIEN=0 F  S BGPIEN=$O(^DPT("ADOB",BGPDOB,BGPIEN)) Q:'BGPIEN  D
  1.  .. S:'$D(BGPPATE(BGPCNT)) BGPPATE(BGPCNT)=0
  1.  .. S BGPCNT=BGPCNT+1,BGPPATE=1
  1.  .. S BGPPATE(BGPCNT)=BGPIEN
  1.  S BGPPATE=BGPCNT
  1.  Q $G(BGPPATE)
  1.  ;
  1. PATNAM(BGPPATE,PAT,NPAT) ;lookup by name
  1.  S BGPCNT=0,BGPPATE=0
  1.  N BGPLEN
  1.  S BGPLEN=$L(PAT)
  1.  S BGPNAM=PAT
  1.  S BGPNAM=$$BEGIN(PAT)
  1.  I $G(NPAT)]"" S BGPNAM=NPAT
  1.  F  S BGPNAM=$O(^DPT("B",BGPNAM)) Q:BGPNAM=""!($E(BGPNAM,1,BGPLEN)'=PAT)  D
  1.  . S BGPIEN=0 F  S BGPIEN=$O(^DPT("B",BGPNAM,BGPIEN)) Q:'BGPIEN  D
  1.  .. N BGPOEN
  1.  .. I $O(^DPT("B",BGPNAM,BGPIEN,0)) D
  1.  ... S BGPOEN=0 F  S BGPOEN=$O(^DPT("B",BGPNAM,BGPIEN,BGPOEN)) Q:'BGPOEN  D
  1.  .... ;Q:$O(^DPT("B",BGPNAM,BGPIEN,0))  ;cmi/maw 4/25/2005 don't get aliases
  1.  .... S BGPCNT=BGPCNT+1
  1.  .... S:'$D(BGPPATE(BGPCNT)) BGPPATE(BGPCNT)=0
  1.  .... S BGPPATE(BGPCNT)=BGPIEN_U_BGPNAM
  1.  .. I '$O(^DPT("B",BGPNAM,BGPIEN,0)) D
  1.  ... S BGPCNT=BGPCNT+1
  1.  ... S:'$D(BGPPATE(BGPCNT)) BGPPATE(BGPCNT)=0
  1.  ... S BGPPATE(BGPCNT)=BGPIEN
  1.  S BGPPATE=BGPCNT
  1.  Q $G(BGPPATE)
  1.  ;
  1. BEGIN(PT) ;EP -- get begin point
  1.  N BGPPDA,BGPPIEN,BGPPCNT
  1.  S BGPPCNT=0
  1.  S BGPPDA=PT
  1.  I $O(^DPT("B",BGPPDA,0)) D
  1.  . S BGPPDA=$O(^DPT("B",BGPPDA),-1)
  1.  F  S BGPPDA=$O(^DPT("B",BGPPDA)) Q
  1.  I $G(BGPPDA)="" Q ""
  1.  Q $O(^DPT("B",BGPPDA),-1)
  1.  ;
  1. PATADO(PIEN) ;EP -- ado return
  1.  S BGPCNTR=0
  1.  S BGPDA=0 F  S BGPDA=$O(PIEN(BGPDA)) Q:'BGPDA  D
  1.  . S BGPPI=$P($G(PIEN(BGPDA)),U)
  1.  . S BGPAL=$P($G(PIEN(BGPDA)),U,2)
  1.  . ;D PTSEC^DGSEC4(.BGPDG,BGPPI,0)  ;logs patient, cant do here
  1.  . D DGSEC(.BGPDG,BGPPI,DUZ,0)  ;don't log patient but get sensitivity info for patient lookup
  1.  . N BGPDGMSG,BGPFLAG
  1.  . I $G(BGPDG(1)) D
  1.  .. S BGPFLAG=BGPDG(1)
  1.  .. N BGPDGDA
  1.  .. S BGPDGMSG=""
  1.  .. S BGPDGDA=1 F  S BGPDGDA=$O(BGPDG(BGPDGDA)) Q:'BGPDGDA  D
  1.  ... I $E(BGPDG(BGPDGDA),1,3)="* *" Q
  1.  ... S BGPDGMSG=BGPDGMSG_" "_$G(BGPDG(BGPDGDA))
  1.  . S BGPDGMSG=$TR($G(BGPDGMSG),"*")
  1.  . I BGPCNTR>BGPMT Q
  1.  . S BGPCNTR=BGPCNTR+1
  1.  . S BGPNM=$S(BGPAL]"":BGPAL_"  ",1:"")_$P($G(^DPT(BGPPI,0)),U)
  1.  . ;S BGPDB=$$FMTE^XLFDT($P($G(^DPT(BGPPI,0)),U,3))
  1.  . S BGPDB=$$LVDT($P($G(^DPT(BGPPI,0)),U,3))
  1.  . I $G(BGPFLAG),$G(BGPFLAG)'=4,$G(BGPFLAG)'=3 S BGPDB="**SENSITIVE**"
  1.  . S BGPSX=$P($G(^DPT(BGPPI,0)),U,2)
  1.  . S BGPCT=$$HRN^AUPNPAT(BGPPI,BGPDUZ2)
  1.  . S BGPSSN=$P($G(^DPT(BGPPI,0)),U,9)
  1.  . I BGPSSN]"" D
  1.  .. N LN
  1.  .. S LN=$L(BGPSSN)
  1.  .. S BGPSSN="XXX-XX-"_$E(BGPSSN,(LN-3),LN)
  1.  . I $G(BGPFLAG),$G(BGPFLAG)'=4,$G(BGPFLAG)'=3 S BGPSSN="**SENSITIVE**"
  1.  . S BGPUPD=$P($G(^AUPNPAT(BGPPI,0)),U,3)  ;cmi/maw 5/17/2007 added last reg update
  1.  . ;S BGPELG=$$GET1^DIQ(9000001,BGPPI,1111)  ;cmi/maw 5/17/2007 added class/ben for status bar
  1.  . S BGPDOD=$S($P($G(^DPT(BGPPI,.35)),U):$$LVDT($P($G(^DPT(BGPPI,.35)),U)),1:"")
  1.  . S BGPAGE=$$AGE^AUPNPAT(BGPPI,DT)
  1.  . I $G(BGPFLAG) S BGPAGE="**SENSITIVE**"
  1.  . I '$G(BGPFLAG),$$GET1^DIQ(43,1,9999999.01)="YES" S BGPFLAG=9  ;ihs/cmi/maw 12/6/2010 for track all patients spt
  1.  . S BGPI=BGPI+1
  1.  . S ^BGPTMP($J,BGPI)=BGPPI_U_BGPNM_U_BGPDB_U_BGPSX_U_BGPCT_U_BGPSSN_U_$G(BGPHD)_U_$G(BGPMORE)_U_BGPDOD_U_BGPAGE_U_$G(BGPFLAG)_U_$E(BGPDGMSG,1,2500)_$C(30)
  1.  Q
  1.  ;
  1. PATSTR(RETVAL,BGPSTR) ;EP -- return the patient demographic information
  1.  S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap
  1.  N BGPI,BGPERRR,BGPUIEN,P
  1.  S P="|"
  1.  K ^BGPTMP($J)
  1.  S RETVAL="^BGPTMP("_$J_")"
  1.  S BGPI=0
  1.  S BGPERRR=""
  1.  S ^BGPTMP($J,BGPI)="T00010IEN^T00030PATIENTNAME^T00015DOB^T00001SEX^T00007CHART^T00009SSN^T00010REG^T00030MORE^T00030DOD^T00010AGE^T00001MESSAGEFLAG^T02500MESSAGE"_$C(30)
  1.  S BGPPAT(1)=$P(BGPSTR,P,2)
  1.  S BGPDUZ2=$P(BGPSTR,P)
  1.  S BGPMT=9999999
  1.  D PATADO(.BGPPAT)
  1.  S ^BGPTMP($J,BGPI+1)=$C(31)
  1.  Q
  1.  ;
  1. LOGPAT(RETVAL,BGPSTR) ;-- log sensitive patient information
  1.  S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap
  1.  N BGPI,BGPERRR,BGPPAT,P,BGPFLAG,BGPDGMSG,BGPDGDA,RESULT
  1.  S P="|"
  1.  K ^BGPTMP($J)
  1.  S RETVAL="^BGPTMP("_$J_")"
  1.  S BGPI=0
  1.  S BGPPAT=$P(BGPSTR,P)
  1.  D DGSEC(.RESULT,BGPPAT,DUZ,0)  ;cmi/maw 3/4/2010 logging takes place in NOTICE^DGSEC4
  1.  I $G(RESULT(1))=4 S BGPFLAG=1
  1.  I $G(RESULT(1))=3 S BGPFLAG=1
  1.  I '$G(BGPFLAG),$G(RESULT(1))'=0 D NOTICE^DGSEC4(.RESULT,BGPPAT,"BGPGRPC^CRS GUI",3)
  1.  I $G(RESULT(1))=0,$$GET1^DIQ(43,1,9999999.01)="YES" D  ;ihs/cmi/maw 12/6/2010 added for track all
  1.  . D NOTICE^DGSEC4(.RESULT,BGPPAT,"BGPGRPC^CRS GUI",$S($P($G(^DGSL(38.1,BGPPAT,0)),U,2):3,1:1))
  1.  S @RETVAL@(BGPI)="T00001Return"_$C(30)
  1.  S BGPI=BGPI+1
  1.  S @RETVAL@(BGPI)=$G(RESULT)_$C(30)
  1.  S @RETVAL@(BGPI+1)=$C(31)
  1.  Q
  1.  ;
  1. DGSEC(RESULT,DFN,DUZ,DGMSG) ;EP -- mock the dgsec call but dont log, couldnt find a way to call PTSEC^DGSEC4 without logging
  1.  S DGMSG=$G(DGMSG,1)
  1.  I $$STATUS^BDGSPT2(DUZ,DFN,1)["RESTRICTED ACCESS" D  Q
  1.  .S RESULT(1)=5 Q:DGMSG'=1
  1.  .S RESULT(2)="Sorry, you are restricted from accessing this patient's record."
  1.  .S RESULT(3)="If you have questions, please contact your HIM department."
  1.  D OWNREC^DGSEC4(.RESULT,DFN,$G(DUZ),DGMSG)
  1.  I RESULT(1)=1 S RESULT(1)=3 Q
  1.  I RESULT(1)=2 S RESULT(1)=4 Q
  1.  K RESULT
  1.  D SENS^DGSEC4(.RESULT,DFN,$G(DUZ))
  1.  Q
  1.  ;
  1. LVDT(PDT) ;EP - return date for list view format
  1.  I PDT="" Q ""
  1.  Q $E(PDT,4,5)_"/"_$E(PDT,6,7)_"/"_($E(PDT,1,3)+1700)
  1.  ;