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

BCHDL1.m

Go to the documentation of this file. 
  1. BCHDL1 ; IHS/TUCSON/LAB - PROCESS CHR RECORD LIST ;  [ 06/26/02  5:49 AM ]
  1.  ;;1.0;IHS RPMS CHR SYSTEM;**7,8,12,13,14**;OCT 28, 1996
  1.  ;IHS/CMI/LAB - patch 8 Y2K
  1.  ;IHS/CMI/LAB - tmp to xtmp
  1.  ;
  1.  ;Continuation of BCHDL.
  1.  ;
  1.  ;
  1. START ;
  1.  S ^XTMP("BCHDL",0)=$$FMADD^XLFDT(DT,14)_U_DT_"CHR DOWNLOAD"
  1.  S BCHBTH=$H,BCHJOB=$J,BCHD=""",""",BCHC=","
  1.  S BCHPROC=BCHPTVS_BCHTYPE
  1.  D @BCHPROC
  1.  D PRINT
  1.  D END
  1.  Q
  1.  ;
  1.  ;
  1. PP ;
  1.  S BCHR=0 F  S BCHR=$O(^DPT(BCHR)) Q:BCHR'=+BCHR  I '$P(^DPT(BCHR,0),U,19) S DFN=BCHR D PROC
  1.  Q
  1.  ;
  1. PS ;
  1.  S BCHR=0 F  S BCHR=$O(^DIBT(BCHSEAT,1,BCHR)) Q:BCHR'=+BCHR  I $D(^DPT(BCHR,0)),'$P(^(0),U,19) S DFN=BCHR D PROC,EOJ
  1.  Q
  1.  ;
  1.  ;
  1. END ;
  1.  D EOJ
  1.  Q
  1. EOJ ;
  1.  K BCHFOUN,BCHJD,BCHPCNT,BCHPROC,BCHR,BCHSKIP,BCHX,BCHTOTAL,BCHCOUNT
  1.  K BCHFAC,BCHFNUM,BCHRORD,BCHC,BCHD
  1.  K D,D0,DIC,DFN,DI,DQ,J,XBFLG,Y
  1.  Q
  1. PROC ;
  1.  Q:'$D(^AUPNPAT(DFN,41,BCHFAC,0))
  1.  Q:$P(^AUPNPAT(DFN,41,BCHFAC,0),U,2)=""
  1.  I BCHPTVS="P",DFN="" Q
  1.  D SCREENS
  1.  Q:$D(BCHSKIP)
  1.  S ^XTMP("BCHDL",BCHJOB,BCHBTH,"PATIENTS",DFN)=$$TX(DFN)
  1.  Q
  1. SCREENS ;
  1.  K BCHSKIP
  1.  S BCHI=0 F  S BCHI=$O(^BCHTRPT(BCHRPT,11,BCHI)) Q:BCHI'=+BCHI!($D(BCHSKIP))  D
  1.  .I '$P(^BCHSORT(BCHI,0),U,8) D SINGLE Q
  1.  .D MULT
  1.  .Q
  1.  Q
  1. SINGLE ;
  1.  K X,BCHSPEC S X="",BCHX=0
  1.  X:$D(^BCHSORT(BCHI,1)) ^(1)
  1.  I X="" S BCHSKIP="" Q
  1.  I '$D(BCHSPEC),'$D(^BCHTRPT(BCHRPT,11,BCHI,11,"B",X)) S BCHSKIP="" Q
  1.  Q
  1. MULT ;
  1.  K BCHFOUN,BCHSKIP,BCHSPEC,X S BCHX=0,X=""
  1.  X:$D(^BCHSORT(BCHI,1)) ^(1)
  1.  I $O(X(""))="" S BCHSKIP="" Q
  1.  I '$D(BCHSPEC) S Y="" F  S Y=$O(X(Y)) Q:Y=""  I $D(^BCHTRPT(BCHRPT,11,BCHI,11,"B",Y)) S BCHFOUN="" Q
  1.  I $D(BCHSPEC),$D(X) S BCHFOUN=1 Q
  1.  S:'$D(BCHFOUN) BCHSKIP=""
  1.  Q
  1.  ;
  1. TX(DFN) ;create tx record
  1.  NEW C,A,T,S,H,%,%1,N,DOB,SSN,R,FN,LN,MN,SA,CTY,ST,ZIP,HPH
  1. NAME S N=$P(^DPT(DFN,0),U),S=$P(^(0),U,2),DOB=$P(^(0),U,3),SSN=$P(^(0),U,9)
  1.  S LN=$P(N,","),FN=$P($P(N,",",2)," "),MN=$P($P(N,",",2)," ",2)
  1.  ;convert dob
  1.  S DOB=$E(DOB,4,5)_"/"_$E(DOB,6,7)_"/"_(1700+$E(DOB,1,3))
  1.  S T=$P($G(^AUPNPAT(DFN,11)),U,8) I T]"" D
  1.  .S T=$P($G(^AUTTTRI(T,0)),U,2)
  1. COMM ;
  1.  S %=0,%1="",C="" F  S %=$O(^AUPNPAT(DFN,51,%)) Q:%'=+%  S %1=%
  1.  I %1]"" D
  1.  .S %1=$P(^AUPNPAT(DFN,51,%1,0),U,3) I %1,$D(^AUTTCOM(%1,0)) S C=$P(^AUTTCOM(%1,0),U,8)
  1. H ;HRN
  1.  S H=$P($G(^AUPNPAT(DFN,41,BCHFAC,0)),U,2)
  1.  S M=$P(^AUPNPAT(DFN,0),U,2),M=$E(M,4,5)_"/"_$E(M,6,7)_"/"_(1700+$E(M,1,3))
  1.  S SA=$P($G(^DPT(DFN,.11)),U)
  1.  S CTY=$P($G(^DPT(DFN,.11)),U,4)
  1.  S ST=$$VAL^XBDIQ1(2,DFN,.115)
  1.  S ZIP=$P($G(^DPT(DFN,.11)),U,6)
  1.  S HPH=$P($G(^DPT(DFN,.13)),U,1)
  1.  S R=LN_"|"_FN_"|"_MN_"|"_H_"|"_SSN_"|"_DOB_"|"_S_"|"_T_"|"_C_"|"_$P(^AUTTLOC(BCHFAC,0),U,10)_"|"_$P($G(^AUTTSITE(1,1)),U,3)_"|"_M_"|"_SA_"|"_CTY_"|"_ST_"|"_ZIP_"|"_HPH_"|"_$$UID^AGTXID(DFN)
  1.  Q R
  1. QU(X) ;quote a string
  1.  I X]"" S X=""""_X_""""
  1.  Q X
  1.  ;
  1. LASTVD(P,F) ;PEP - given patient DFN, return pt's last pcc visit date, using
  1.  ;         the data fetcher.  Returns date in format specified in F.
  1.  I '$G(P) Q ""
  1.  I $G(F)="" S F="I"
  1.  I '$D(^AUPNVSIT("AC",P)) Q ""
  1.  NEW Y,ERR,LVD
  1.  S ERR=$$^APCLDF(P_"^LAST VISIT","LVD(")
  1.  I LVD(1)="" Q LVD
  1.  S Y=$P(LVD(1),U)
  1.  ;begin Y2K
  1.  ;Q $S($G(F)="S":$$FMTE^XLFDT(Y,"2D"),$G(F)="E":$$FMTE^XLFDT(Y,"1D"),1:$P(Y,".")) ;Y2000
  1.  Q $S($G(F)="E":$$FMTE^XLFDT(Y,"1D"),1:$P(Y,".")) ;Y2000
  1.  ;end Y2K
  1.  ;
  1.  ;
  1. PRINT ;EP CALLED FROM XBDBQUE
  1.  ;S BCHFILE="ch"_$P(^AUTTLOC(BCHFAC,0),U,10)_".imp"
  1.  ;create flat file calling XBGSAVE
  1.  ;GO THROUGH ^XTMP AND SET IN ^TMP($J,"PATIENTS")
  1.  K ^TMP($J,"PATIENTS")
  1.  ;
  1.  S (BCHX,BCHTOTAL,BCHCOUNT,BCHFNUM,BCHMULTI)=0,BCHRORD=""
  1.  S BCHRORD=$O(^XTMP("BCHDL",BCHJOB,BCHBTH,"PATIENTS",BCHRORD),-1)
  1.  F  S BCHX=$O(^XTMP("BCHDL",BCHJOB,BCHBTH,"PATIENTS",BCHX)) Q:BCHX'=+BCHX  D
  1.  .  S ^TMP($J,"PATIENTS",BCHX)=^XTMP("BCHDL",BCHJOB,BCHBTH,"PATIENTS",BCHX)
  1.  .  ;K ^XTMP("BCHDL",BCHJOB,BCHBTH,"PATIENTS",BCHX)
  1.  .  ;S BCHCOUNT=BCHCOUNT+1
  1.  .  S BCHTOTAL=BCHTOTAL+1
  1.  D WRITEF
  1.  ;D:BCHMULTI MULTFILE
  1.  D WRITEFX
  1.  Q
  1.  ;
  1. FILE ; setup file name(s)
  1.  S BCHFNUM=BCHFNUM+1
  1.  S BCHFILE="chrpat"_BCHFNUM_".imp"
  1.  S BCHFILE(BCHFNUM)=BCHFILE
  1.  S BCHFILE(BCHFNUM,"COUNT")=BCHCOUNT
  1.  S:BCHFNUM=2 BCHMULTI=1 ;       flag set is multiple files generated
  1.  S BCHCOUNT=0
  1.  Q
  1.  ;
  1. MULTFILE ; information regarding multiple files
  1.  Q:$D(ZTQUEUED)
  1.  Q:'BCHMULTI
  1.  W @IOF
  1.  W:'$D(ZTQUEUED) !!,$C(7),$C(7),"A TOTAL of *** ",BCHTOTAL," *** patients were downloaded to the following files:",!,"(Each file contains a maximum of 2000 patients.)",!!
  1.  S BCHFNUM=0
  1.  F BCHN=1:1 S BCHFNUM=$O(BCHFILE(BCHFNUM)) Q:BCHFNUM=""  W !?5,"/usr/spool/uucppublic/",BCHFILE(BCHFNUM),?45,"("_BCHFILE(BCHFNUM,"COUNT")_") patients",!
  1.  W:'$D(ZTQUEUED) !!!
  1.  K BCHN,BCHFNUM
  1.  Q
  1.  ;
  1. WRITEF ;EP - write out flat file
  1.  S XBGL="TMP("_$J_",""PATIENTS"","
  1.  S XBMED="F",XBFN=BCHFILE,XBTLE="SAVE OF PATIENTS FOR CHR DOWNLOAD -"_$P(^VA(200,BCHCHR,0),U)
  1.  S XBF=0,XBQ="N",XBFLT=1,XBE=$J
  1.  W:'$D(ZTQUEUED) !!
  1.  D ^XBGSAVE
  1.  Q
  1.  ;
  1. WRITEFX ;
  1.  W:'$D(ZTQUEUED)&('BCHMULTI) !!,$C(7),$C(7),"A TOTAL of *** ",BCHTOTAL," *** patients were downloaded.",!!
  1.  K ^TMP($J,"PATIENTS")
  1.  K ^XTMP("BCHDL",BCHJOB,BCHBTH),BCHJOB,BCHBTH,BCHX
  1.  K XBGL,XBMED,XBTLE,XBFN,XBF,XBQ,XBFLT
  1.  K BCHFNUM,BCHN,BCHRORD,BCHMULTI
  1.  Q