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

BCHRU11.m

Go to the documentation of this file. 
  1. BCHRU11 ; IHS/CMI/LAB - PROCESS REPORT ; 
  1.  ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
  1.  ;IHS/CMI/LAB - tmp to xtmp
  1.  ;
  1.  ;
  1.  ;
  1.  ;
  1. START ;
  1.  S (BCHBT,BCHBTH)=$H,BCHJOB=$J
  1.  K ^XTMP("BCHRU1",BCHJOB,BCHBT)
  1.  D XTMP^BCHUTIL("BCHRU1","CHR UNDUP REPORT")
  1.  D D,END
  1.  Q
  1.  ;
  1. D ; Run by date of service
  1.  S (BCHPATS,BCHPATS("F"),BCHPATS("M"),BCHPATS("ST"))=0
  1.  S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X
  1.  S BCHODAT=BCHSD_".9999" F  S BCHODAT=$O(^BCHR("B",BCHODAT)) Q:BCHODAT=""!((BCHODAT\1)>BCHED)  D D1
  1.  Q
  1.  ;
  1. END ;
  1.  S BCHET=$H
  1.  D EOJ
  1.  Q
  1. EOJ ;
  1.  Q
  1. D1 ;
  1.  S (BCHR,BCHRCNT)=0
  1.  F  S BCHR=$O(^BCHR("B",BCHODAT,BCHR)) Q:BCHR'=+BCHR  I $D(^BCHR(BCHR,0)),$P(^(0),U,2)]"",$P(^(0),U,3)]"" S BCHR0=^(0) D PROC
  1.  Q
  1. PROC ;
  1.  S BCHPROG=$P(BCHR0,U,2)
  1.  I BCHPRG,BCHPRG'=BCHPROG Q
  1.  S BCHPROV=$P(BCHR0,U,3)
  1.  I BCHPROVT="O",BCHCHR1'=BCHPROV Q
  1.  S BCHPAT=$P(BCHR0,U,4)
  1.  S BCHNRPAT=$P($G(^BCHR(BCHR,11)),U,12)
  1.  I 'BCHPAT,'BCHNRPAT Q   ;no patient
  1.  I BCHREG="R",BCHPAT="" Q
  1.  I BCHREG="N",BCHNRPAT="" Q
  1.  I BCHPAT,BCHNRPAT S BCHNRPAT=""
  1.  I BCHPAT Q:'$D(^DPT(BCHPAT,0))
  1.  I BCHPAT S BCHSEX=$P(^DPT(BCHPAT,0),U,2)
  1.  I BCHNRPAT S BCHSEX=$P($G(^BCHRPAT(BCHNRPAT,0)),U,3)
  1.  I BCHSEX="" S BCHSEX="--"
  1.  I BCHPAT S BCHTRIB=$$VAL^XBDIQ1(9000001,BCHPAT,1108)
  1.  I BCHNRPAT S BCHTRIB=$$VAL^XBDIQ1(90002.11,BCHNRPAT,.05)
  1.  I BCHTRIB="" S BCHTRIB="--"
  1.  S (BCHX,BCHC)=0 F  S BCHX=$O(^BCHRPROB("AD",BCHR,BCHX)) Q:BCHX'=+BCHX  S BCHC=BCHC+1 I $P(^BCHRPROB(BCHX,0),U,4),$P(^BCHTSERV($P(^BCHRPROB(BCHX,0),U,4),0),U,3)'="LT" D @BCHRPT D
  1.  .;BY 1ST LEVEL - TOTAL LINE
  1.  .I BCHNRPAT D NON Q
  1.  .S BCHPATS("ST")=BCHPATS("ST")+$P(^BCHRPROB(BCHX,0),U,5)
  1.  .I '$D(^XTMP("BCHRU1",BCHJOB,BCHBT,"PATIENTS",BCHPAT)) D
  1.  ..S BCHPATS=BCHPATS+1,BCHPATS(BCHSEX)=BCHPATS(BCHSEX)+1
  1.  ..S ^XTMP("BCHRU1",BCHJOB,BCHBT,"PATIENTS",BCHPAT)=""
  1.  .S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,4)=$P($G(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN)),U,4)+$P(^BCHRPROB(BCHX,0),U,5)
  1.  .S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,4)=$P($G(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1)),U,4)+$P(^BCHRPROB(BCHX,0),U,5)
  1.  .I '$D(^XTMP("BCHRU1",BCHJOB,BCHBT,"PATIENTS",BCHPAT,BCHPROBN)) D
  1.  ..S $P(^(BCHPROBN),U)=$S($D(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN)):$P(^(BCHPROBN),U)+1,1:1)
  1.  ..I BCHSEX="F" S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,2)=$P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,2)+1
  1.  ..I BCHSEX="M" S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,3)=$P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,3)+1
  1.  ..S ^XTMP("BCHRU1",BCHJOB,BCHBT,"PATIENTS",BCHPAT,BCHPROBN)=""
  1.  .;SUBTOTALS
  1.  .I '$D(^XTMP("BCHRU1",BCHJOB,BCHBT,"PATIENTS",BCHPAT,BCHPROBN,BCHSUB1)) D
  1.  ..S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U)=$S($D(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1)):$P(^(BCHSUB1),U)+1,1:1)
  1.  ..I BCHSEX="F" S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,2)=$P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,2)+1
  1.  ..I BCHSEX="M" S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,3)=$P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,3)+1
  1.  ..S ^XTMP("BCHRU1",BCHJOB,BCHBT,"PATIENTS",BCHPAT,BCHPROBN,BCHSUB1)=""
  1.  Q
  1. X ;health area
  1.  S BCHPROB=$P(^BCHRPROB(BCHX,0),U)
  1.  S BCHPROBN=$P(^BCHTPROB(BCHPROB,0),U)_"|"_$P(^BCHTPROB(BCHPROB,0),U,2)
  1.  S BCHSUB1=$P(^BCHRPROB(BCHX,0),U,4)
  1.  I BCHSUB1="" S BCHSUB1="NO ACTIVITY ENTERED|**" Q
  1.  S BCHSUB1=$P(^BCHTSERV(BCHSUB1,0),U)_"|"_$P(^BCHTSERV(BCHSUB1,0),U,3)
  1.  Q
  1. Y ;activity
  1.  S BCHPROB=$P(^BCHRPROB(BCHX,0),U,4)
  1.  I BCHPROB="" S BCHPROBN="NO SERVICE ENTERED|**"
  1.  I BCHPROB]"" S BCHPROBN=$P(^BCHTSERV(BCHPROB,0),U)_"|"_$P(^BCHTSERV(BCHPROB,0),U,3)
  1.  S BCHSUB1=$P(^BCHRPROB(BCHX,0),U)
  1.  I BCHSUB1="" S BCHSUB1="NO PROBLEM ENTERED|**" Q
  1.  S BCHSUB1=$P(^BCHTPROB(BCHSUB1,0),U)_"|"_$P(^BCHTPROB(BCHSUB1,0),U,2)
  1.  Q
  1. 1 ;CHR
  1.  S BCHPROB=$$VAL^XBDIQ1(90002,BCHR,.03)
  1.  I BCHPROB="" S BCHPROBN="NO CHR ENTERED|**"
  1.  I BCHPROB]"" S BCHPROBN="|"_BCHPROB
  1.  I BCHSUB3="H" D
  1.  .S BCHSUB1=$P(^BCHRPROB(BCHX,0),U)
  1.  .I BCHSUB1="" S BCHSUB1="NO PROBLEM ENTERED|**" Q
  1.  .S BCHSUB1=$P(^BCHTPROB(BCHSUB1,0),U)_"|"_$P(^BCHTPROB(BCHSUB1,0),U,2)
  1.  I BCHSUB3'="H" D
  1.  .S BCHSUB1=$P(^BCHRPROB(BCHX,0),U,4)
  1.  .I BCHSUB1="" S BCHSUB1="NO ACTIVITY ENTERED|**" Q
  1.  .S BCHSUB1=$P(^BCHTSERV(BCHSUB1,0),U)_"|"_$P(^BCHTSERV(BCHSUB1,0),U,3)
  1.  Q
  1. 2 ;age/hp
  1.  I BCHPAT S BCHPROB=$$AGE^AUPNPAT(BCHPAT,BCHED),BCHPROB=$$PAD(BCHPROB,4)
  1.  I BCHNRPAT S BCHPROB=$$AGE(BCHNRPAT,BCHED),BCHPROB=$$PAD(BCHPROB,4)
  1.  S BCHPROBN="|"_BCHPROB
  1.  I BCHSUB3="H" D
  1.  .S BCHSUB1=$P(^BCHRPROB(BCHX,0),U)
  1.  .I BCHSUB1="" S BCHSUB1="NO PROBLEM ENTERED|**" Q
  1.  .S BCHSUB1=$P(^BCHTPROB(BCHSUB1,0),U)_"|"_$P(^BCHTPROB(BCHSUB1,0),U,2)
  1.  I BCHSUB3'="H" D
  1.  .S BCHSUB1=$P(^BCHRPROB(BCHX,0),U,4)
  1.  .I BCHSUB1="" S BCHSUB1="NO ACTIVITY ENTERED|**" Q
  1.  .S BCHSUB1=$P(^BCHTSERV(BCHSUB1,0),U)_"|"_$P(^BCHTSERV(BCHSUB1,0),U,3)
  1.  Q
  1. 3 ;
  1.  S BCHPROB=$S(BCHSEX="M":"MALE",BCHSEX="F":"FEMALE",1:"UNKNOWN")
  1.  S BCHPROBN="|"_BCHPROB
  1.  I BCHSUB3="H" D
  1.  .S BCHSUB1=$P(^BCHRPROB(BCHX,0),U)
  1.  .I BCHSUB1="" S BCHSUB1="NO PROBLEM ENTERED|**" Q
  1.  .S BCHSUB1=$P(^BCHTPROB(BCHSUB1,0),U)_"|"_$P(^BCHTPROB(BCHSUB1,0),U,2)
  1.  I BCHSUB3'="H" D
  1.  .S BCHSUB1=$P(^BCHRPROB(BCHX,0),U,4)
  1.  .I BCHSUB1="" S BCHSUB1="NO ACTIVITY ENTERED|**" Q
  1.  .S BCHSUB1=$P(^BCHTSERV(BCHSUB1,0),U)_"|"_$P(^BCHTSERV(BCHSUB1,0),U,3)
  1.  Q
  1. 4 ;
  1.  S BCHPROB=BCHTRIB
  1.  S BCHPROBN="|"_BCHPROB
  1.  I BCHSUB3="H" D
  1.  .S BCHSUB1=$P(^BCHRPROB(BCHX,0),U)
  1.  .I BCHSUB1="" S BCHSUB1="NO PROBLEM ENTERED|**" Q
  1.  .S BCHSUB1=$P(^BCHTPROB(BCHSUB1,0),U)_"|"_$P(^BCHTPROB(BCHSUB1,0),U,2)
  1.  I BCHSUB3'="H" D
  1.  .S BCHSUB1=$P(^BCHRPROB(BCHX,0),U,4)
  1.  .I BCHSUB1="" S BCHSUB1="NO ACTIVITY ENTERED|**" Q
  1.  .S BCHSUB1=$P(^BCHTSERV(BCHSUB1,0),U)_"|"_$P(^BCHTSERV(BCHSUB1,0),U,3)
  1.  Q
  1. 5 ;
  1.  S BCHPROB=$$VAL^XBDIQ1(90002,BCHR,.02)
  1.  I BCHPROB="" S BCHPROBN="NO PROGRAM ENTERED|**"
  1.  I BCHPROB]"" S BCHPROBN=$$VAL^XBDIQ1(90002,BCHR,.029)_"|"_BCHPROB
  1.  I BCHSUB3="H" D
  1.  .S BCHSUB1=$P(^BCHRPROB(BCHX,0),U)
  1.  .I BCHSUB1="" S BCHSUB1="NO PROBLEM ENTERED|**" Q
  1.  .S BCHSUB1=$P(^BCHTPROB(BCHSUB1,0),U)_"|"_$P(^BCHTPROB(BCHSUB1,0),U,2)
  1.  I BCHSUB3'="H" D
  1.  .S BCHSUB1=$P(^BCHRPROB(BCHX,0),U,4)
  1.  .I BCHSUB1="" S BCHSUB1="NO ACTIVITY ENTERED|**" Q
  1.  .S BCHSUB1=$P(^BCHTSERV(BCHSUB1,0),U)_"|"_$P(^BCHTSERV(BCHSUB1,0),U,3)
  1.  Q
  1. PAD(D,L) ; -- SUBRTN to pad length of data
  1.  ; -- D=data L=length
  1.  S L=L-$L(D)
  1.  Q $E($$REPEAT^XLFSTR(" ",L),1,L)_D
  1.  ;
  1. NON ;
  1.  S BCHPATS("ST")=BCHPATS("ST")+$P(^BCHRPROB(BCHX,0),U,5)
  1.  I '$D(^XTMP("BCHRU1",BCHJOB,BCHBT,"NON REG",BCHNRPAT)) D
  1.  .S BCHPATS=BCHPATS+1,BCHPATS(BCHSEX)=$G(BCHPATS(BCHSEX))+1
  1.  .S ^XTMP("BCHRU1",BCHJOB,BCHBT,"NON REG",BCHNRPAT)=""
  1.  S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,4)=$P($G(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN)),U,4)+$P(^BCHRPROB(BCHX,0),U,5)
  1.  S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,4)=$P($G(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1)),U,4)+$P(^BCHRPROB(BCHX,0),U,5)
  1.  I '$D(^XTMP("BCHRU1",BCHJOB,BCHBT,"NON REG",BCHNRPAT,BCHPROBN)) D
  1.  .S $P(^(BCHPROBN),U)=$S($D(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN)):$P(^(BCHPROBN),U)+1,1:1)
  1.  .I BCHSEX="F" S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,2)=$P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,2)+1
  1.  .I BCHSEX="M" S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,3)=$P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,3)+1
  1.  .S ^XTMP("BCHRU1",BCHJOB,BCHBT,"NON REG",BCHNRPAT,BCHPROBN)=""
  1.  ;SUBTOTALS
  1.  I '$D(^XTMP("BCHRU1",BCHJOB,BCHBT,"NON REG",BCHNRPAT,BCHPROBN,BCHSUB1)) D
  1.  .S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U)=$S($D(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1)):$P(^(BCHSUB1),U)+1,1:1)
  1.  .I BCHSEX="F" S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,2)=$P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,2)+1
  1.  .I BCHSEX="M" S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,3)=$P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,3)+1
  1.  .S ^XTMP("BCHRU1",BCHJOB,BCHBT,"NON REG",BCHNRPAT,BCHPROBN,BCHSUB1)=""
  1.  Q
  1. AGE(P,E) ;
  1.  NEW D,A,%
  1.  S F="Y"
  1.  S D=$P($G(^BCHRPAT(P,0)),U,2)
  1.  I D="" Q "??"
  1.  S %=$$FMDIFF^XLFDT(E,D)
  1.  S %1=%\365.25
  1.  I F="Y" Q %1
  1.  Q $S(%1>2:%1_" YRS",%<31:%_" DYS",1:%\30_" MOS")