BCHDLN1.m

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