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