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

BGP9GUA.m

Go to the documentation of this file. 
  1. BGP9GUA ; IHS/CMI/LAB - BGP Gui Utilities 10/29/2004 3:28:39 PM 19 Sep 2005 5:28 PM 27 Apr 2008 10:28 PM ;
  1.  ;;9.0;IHS CLINICAL REPORTING;**1**;JUL 01, 2009
  1.  ;
  1.  ;
  1. DEBUG(RETVAL,BGPSTR) ;run the debugger
  1.  D DEBUG^%Serenji("LABTAXC^BGP9GU(.RETVAL,.BGPSTR)")
  1.  Q
  1.  ;
  1. GETPAT(BGPRET,BGPSTR) ;-- return patient in ADO table
  1.  S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap
  1.  N BGPI,BGPERR,BGPUIEN,P
  1.  S P="|"
  1.  K ^BGPTMP($J)
  1.  S BGPRET="^BGPTMP("_$J_")"
  1.  S BGPI=0
  1.  S BGPERR=""
  1.  S ^BGPTMP($J,BGPI)="T00010IEN^T00030PATIENTNAME^T00015DOB^T00001SEX^T00007CHART^T00009SSN^T00010REG^T00030LAST UPDATE^T00030CLASSBEN^T00010AGE"_$C(30)
  1.  S BGPPAT=$P(BGPSTR,P,2)
  1.  S BGPMT=$P(BGPSTR,P,3)
  1.  S BGPNPAT=$P(BGPSTR,P,4)
  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)_$G(BGPERR)
  1.  K BGPPAT,BGPPIEN,BGPCNT,BGPDA,BGPIEN,BGPPATE,BGPNM,BGPDB,BGPSX,BGPCT,BGPSSN
  1.  K BGPPATS
  1.  Q
  1.  ;
  1. PATSSN(PAT) ;-- 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) ;-- lookup by chart
  1.  N BGPCNT
  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.  .. I $O(^AUPNPAT("D",BGPDA,BGPIEN,0))=DUZ(2) S BGPPIEN=BGPIEN
  1.  .. Q:'$G(BGPPIEN)
  1.  .. ;
  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) ;-- 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)!(BGPCNT>BGPMT)  D
  1.  . S BGPIEN=0 F  S BGPIEN=$O(^DPT("B",BGPNAM,BGPIEN)) Q:'BGPIEN  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
  1.  S BGPPATE=BGPCNT
  1.  Q $G(BGPPATE)
  1.  ;
  1. BEGIN(PT) ;-- 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) ;-- ado return
  1.  S BGPCNTR=0
  1.  S BGPDA=0 F  S BGPDA=$O(PIEN(BGPDA)) Q:'BGPDA  D
  1.  . S BGPCNTR=BGPCNTR+1
  1.  . S BGPPI=$G(PIEN(BGPDA))
  1.  . S BGPNM=$P($G(^DPT(BGPPI,0)),U)
  1.  . S BGPDB=$$FMTE^XLFDT($P($G(^DPT(BGPPI,0)),U,3))
  1.  . S BGPSX=$P($G(^DPT(BGPPI,0)),U,2)
  1.  . S BGPCT=$$HRN^AUPNPAT(BGPPI,DUZ(2))
  1.  . S BGPSSN=$P($G(^DPT(BGPPI,0)),U,9)
  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 BGPAGE=$$AGE^AUPNPAT(BGPPI,DT)
  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_BGPUPD_U_BGPELG_U_BGPAGE_$C(30)
  1.  Q
  1.  ;
  1. SELSP(RETVAL) ;-- return all sites in the site file for selection
  1.  N BGPI
  1.  S BGPI=0
  1.  S RETVAL="^BGPTMP("_$J_")"
  1.  K ^BGPTMP($J)
  1.  S ^BGPTMP($J,BGPI)="T00050Site"_$C(30)
  1.  N BGPDA
  1.  S BGPDA=0 F  S BGPDA=$O(^BGPSITE("B",BGPDA)) Q:'BGPDA  D
  1.  . N BGPSE
  1.  . S BGPSE=$P($G(^DIC(4,BGPDA,0)),U)
  1.  . S BGPI=BGPI+1
  1.  . S ^BGPTMP($J,BGPI)=BGPSE_$C(30)
  1.  S ^BGPTMP($J,BGPI+1)=$C(31)
  1.  Q
  1.  ;
  1. DEMO(RETVAL,BGPSTR) ;-- cmi/maw 8.0 p2 get demo patients based on Search Template passed in
  1.  N BGPI,BGPST,BGPSTI,P
  1.  S P="|"
  1.  S BGPI=0
  1.  S BGPSTI=$P(BGPSTR,P)
  1.  ;S BGPSTI=$O(^DIBT("B",BGPST,0))
  1.  S RETVAL="^BGPTMP("_$J_")"
  1.  K ^BGPTMP($J)
  1.  S ^BGPTMP($J,BGPI)="T00010IEN^T00030PATIENTNAME^T00015DOB^T00001SEX^T00007CHART^T00009SSN^T00010REG^T00030LAST UPDATE^T00030CLASSBEN^T00010AGE"_$C(30)
  1.  N BGPDA
  1.  S BGPDA=0 F  S BGPDA=$O(^DIBT(BGPSTI,1,BGPDA)) Q:'BGPDA  D
  1.  . N BGPNM,BGPDB,BGPSX,BGPCT,BGPSSN
  1.  . S BGPI=BGPI+1
  1.  . S BGPNM=$P($G(^DPT(BGPDA,0)),U)
  1.  . S BGPDB=$$FMTE^XLFDT($P($G(^DPT(BGPDA,0)),U,3))
  1.  . S BGPSX=$P($G(^DPT(BGPDA,0)),U,2)
  1.  . S BGPCT=$$HRN^AUPNPAT(BGPDA,DUZ(2))
  1.  . S BGPSSN=$P($G(^DPT(BGPDA,0)),U,9)
  1.  . S ^BGPTMP($J,BGPI)=BGPDA_U_BGPNM_U_BGPDB_U_BGPSX_U_BGPCT_U_BGPSSN_U_U_U_U_$C(30)
  1.  S ^BGPTMP($J,BGPI+1)=$C(31)
  1.  Q
  1.  ;
  1. DEMOS(RETVAL,BGPSTR) ;-- cmi/maw 6/11/2008 8.0 p1 save demo template
  1.  N P,R,BGPI,BGPST,BGPSTI,BGPPATS,BGPFDA,BGPERR,BGPIENS
  1.  S P="|",R="~"
  1.  S BGPI=0
  1.  S RETVAL="^BGPTMP("_$J_")"
  1.  S BGPST=$P(BGPSTR,P)
  1.  S BGPPATS=$P(BGPSTR,P,2)
  1.  S BGPSTI=$S($G(BGPST):BGPST,1:$O(^DIBT("B",BGPST,0)))
  1.  S ^BGPTMP($J,BGPI)="T00001Error"_$C(30)
  1.  S P="|"
  1.  I $G(BGPSTI) D  Q
  1.  . D CLNDEMO(BGPSTI)
  1.  . N I
  1.  . F I=1:1 D  Q:$P(BGPPATS,R,I)=""
  1.  .. Q:$P(BGPPATS,R,I)=""
  1.  .. N BGPPAT
  1.  .. S BGPPAT=$P(BGPPATS,R,I)
  1.  .. S ^DIBT(BGPSTI,1,BGPPAT)=""
  1.  . S ^BGPTMP($J,BGPI+1)=$C(31)
  1.  ;S BGPIENS=""
  1.  ;S BGPFDA(.401,"+1,",.01)=BGPST
  1.  ;D UPDATE^DIE("","BGPFDA","BGPIENS","BGPERR(1)")
  1.  ;S BGPSTI=$G(BGPIENS(1))
  1.  ;N I
  1.  ;F I=1:1 D  Q:$P(BGPPATS,R,I)=""
  1.  ;. Q:$P(BGPPATS,R,I)=""
  1.  ;. N BGPPAT
  1.  ;. S BGPPAT=$P(BGPPATS,R,I)
  1.  ;. S ^DIBT(BGPSTI,1,BGPPAT)=""
  1.  S ^BGPTMP($J,BGPI+1)=$C(31)
  1.  Q
  1.  ;
  1. CLNDEMO(STI) ;-- cmi/maw 6/11/2008 8.0 p1 clean up demo template first
  1.  N BGPDA
  1.  S DA(1)=STI
  1.  S DIK="^DIBT("_DA(1)_",1,"
  1.  S BGPDA=0 F  S BGPDA=$O(^DIBT(STI,1,BGPDA)) Q:'BGPDA  D
  1.  . S DA=BGPDA
  1.  . D ^DIK
  1.  K DIK
  1.  Q
  1.  ;
  1. VC(RETVAL,BGPSTR) ;-- get version number to see if client matches
  1.  N P
  1.  S P="|"
  1.  K ^BGPTMP($J)
  1.  N BGPVER,BGPVERI,BGPVERIN,BGPPKG,BGPI,BGPPTCH,BGPPTCHI,BGPVERI
  1.  S BGPI=0
  1.  S BGPVERIN=$P(BGPSTR,P)
  1.  ;S BGPVERIN=8.3
  1.  S RETVAL="^BGPTMP("_$J_")"
  1.  S ^BGPTMP($J,BGPI)="T00001VersionPresent"_$C(30)
  1.  S BGPI=BGPI+1
  1.  S BGPPKG=$O(^DIC(9.4,"C","BGP",0))
  1.  I '$G(BGPPKG) D  Q
  1.  . S ^BGPTMP($J,BGPI)=0_$C(30)
  1.  . S ^BGPTMP($J,BGPI+1)=$C(31)
  1.  S BGPVER=$G(^DIC(9.4,BGPPKG,"VERSION"))
  1.  S BGPVERI=$O(^DIC(9.4,BGPPKG,22,"B",BGPVER,0))
  1.  S BGPPTCH=$O(^DIC(9.4,BGPPKG,22,BGPVERI,"PAH","B",""),-1)
  1.  I ($E(BGPVER,1,2)_BGPPTCH)=BGPVERIN D  Q
  1.  . S ^BGPTMP($J,BGPI)=1_$C(30)
  1.  . S ^BGPTMP($J,BGPI+1)=$C(31)
  1.  ;S ^BGPTMP($J,BGPI)=0_$C(30)  ;remove the line below when done with testing and uncomment this one
  1.  S ^BGPTMP($J,BGPI)=1_$C(30)
  1.  S ^BGPTMP($J,BGPI+1)=$C(31)
  1.  Q
  1.  ;