BSDX41I ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
;
OUTPT ; ********** OUTPATIENT ENCOUNTERS * 9000010/9000010.07 **********
; <SETUP>
Q:'$D(^AUPNVSIT("AA",APCHSPAT))
S APCHSOVT="ARSCOTE" ; NOTE: THIS CONTROLS TYPES OF VISITS DISPLAYED
;X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
; <DISPLAY>
S APCHSPVD=0
S APCHSPFN=""
S APCHSDCX="",APCHSDPR=""
I $D(^APCHSCTL(APCHSTYP,2)),$P(^(2),U,3)="Y" S APCHSDCX=1
I $D(^APCHSCTL(APCHSTYP,2)),$P(^(2),U,5)=1 S APCHSDPR=1
I 'APCHSDPR,'APCHSDCX S APCHSDCL=23
I APCHSDCX,'APCHSDPR S APCHSDCL=32
I APCHSDCX,APCHSDPR S APCHSDCL=35
I 'APCHSDCX,APCHSDPR S APCHSDCL=28
S APCHSICF=$S('$D(APCHSTYP):"L",'$D(^APCHSCTL(APCHSTYP,2)):"L",$P(^APCHSCTL(APCHSTYP,2),U,1)]"":$P(^APCHSCTL(APCHSTYP,2),U,1),1:"L")
F APCHSIVD=0:0 S APCHSIVD=$O(^AUPNVSIT("AA",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) D Q:APCHSNDM=0!(APCHSQT)
. S APCHSQT=1
. D ONEDATE
. Q:$D(APCHSQIT)
. S:(APCHSDAT'=APCHSPVD)&APCHSDTU APCHSNDM=APCHSNDM-APCHSDTU,APCHSPVD=APCHSDAT
. S APCHSQT=0
. Q
;
OUTPTX ; <CLEANUP>
K APCHSIVD,APCHSDTU,APCHSDAT,APCHSVDF,APCHSFAC,APCHSPFN,APCHSSCL,APCHSMTX,APCHSMOD,APCHSPVD,APCHSOVT,APCHSNDT,APCHSCLI,APCHSPDN,APCHSICD,APCHSICL,APCHSNRQ,APCHSDPR,APCHSDCX
K APCHSNFL,APCHSNSH,APCHSCCL,APCHSNAB,APCHSVSC,APCHSITE,APCHSQT,APCHSDCL,Y,APCHCSVD
Q
;
ONEDATE ;
S APCHSCCL=""
S (Y,APCHCSVD)=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
;S (APCHSPFN,APCHSSCL)="",APCHSDTU=0,APCHSNDT=(APCHSDAT'=APCHSPVD)
S APCHSDTU=0,APCHSNDT=(APCHSDAT'=APCHSPVD)
S APCHSVDF="" F APCHSQ=0:0 S APCHSVDF=$O(^AUPNVSIT("AA",APCHSPAT,APCHSIVD,APCHSVDF)) Q:APCHSVDF="" D Q:APCHSQT
. S APCHSQT=1
. S APCHSSCL=""
. S APCHSN=^AUPNVSIT(APCHSVDF,0)
. I $P(APCHSN,U,7)="E",'$D(^AUPNVPOV("AD",APCHSVDF)) S APCHSQT=0 Q ;don't display events with no pov
. I $P(APCHSN,U,7)="I",'$D(^AUPNVPOV("AD",APCHSVDF)) S APCHSQT=0 Q ;don't display in hosp visits with no pov
. I +$P(APCHSN,U,9),'$P(APCHSN,U,11) D GETCLN,GETPROV,GETSITEV D
.. I APCHSOVT[APCHSVSC D DSPVIS
.. Q
. Q:$D(APCHSQIT)
. S APCHSQT=0
. Q
Q
;
GETPROV ;
S APCHSPRV=$$PRIMPROV^APCLV(APCHSVDF,"T")
Q
GETCLN ;
S APCHSCLI=$P(APCHSN,U,8) I APCHSCLI="" S APCHSCCL="<none>" Q
S APCHSCLI=$P(APCHSN,U,8) Q:APCHSCLI=""
Q:'$D(^DIC(40.7,APCHSCLI))
I $D(^DIC(40.7,APCHSCLI,9999999)),$P(^(9999999),U,1)]"" S APCHSCLI=$E($P(^DIC(40.7,APCHSCLI,9999999),U,1),1,6),APCHSCCL=APCHSCLI Q
S APCHSCLI=$E($P(^DIC(40.7,APCHSCLI,0),U,1),1,8)
S APCHSCCL=APCHSCLI
Q
DSPVIS ;
S APCHSDTU=1
I $O(^AUPNVPOV("AD",APCHSVDF,""))="" D NOPOV Q
S APCHSPDN="" F APCHSQ=0:0 S APCHSPDN=$O(^AUPNVPOV("AD",APCHSVDF,APCHSPDN)) Q:'APCHSPDN S APCHSN=^AUPNVPOV(APCHSPDN,0) D HASPOV
Q
;
NOPOV ;
S (APCHSICD,APCHSNRQ)="<purpose of visit not yet entered>",APCHSMOD=""
G COMMON
;
HASPOV ;
S APCHSICD=$P(APCHSN,U,1) D GETICDDX^APCHSUTL
S APCHSNRQ=$P(APCHSN,U,4) D GETNARR^APCHSUTL I $P(APCHSN,U,5)]"" S APCHSNRQ=APCHSNRQ_" (Stage: "_$P(APCHSN,U,5)_")" ;IHS/CMI/LAB - patched to display stage of 0
S APCHSMOD=$P(APCHSN,U,6)
COMMON ;
;X APCHSCKP Q:$D(APCHSQIT) S:APCHSNPG APCHSNDT=1
I APCHSNDT S BSDXTMP=APCHSDAT S (APCHSPFN,APCHSSCL)="",APCHSNDT=0
I APCHSNSH=APCHSPFN S APCHSFAC=""
E S (APCHSFAC,APCHSPFN)=APCHSNSH,APCHSSCL=""
I APCHSCCL=APCHSSCL S APCHSCLI=""
E S (APCHSCLI,APCHSSCL)=APCHSCCL
I APCHSICD["<purpose of visit not"&(APCHSSCL="<none>") S APCHSCLI=""
I APCHSMOD]"" S APCHSMTX=$P(^DD(9000010.07,.06,0),U,3),APCHSMTX=$P($P(APCHSMTX,APCHSMOD_":",2),";",1),APCHSMTX=$P(APCHSMTX,",",1),APCHSICD=APCHSMTX_" "_APCHSICD
S:$D(^AUPNVCHS("AD",APCHSVDF)) APCHSNTE="*** CHS ***"
;S APCHSICL=$S(APCHSCLI'=" ":35,1:23)
S BSDXTMP=BSDXTMP_$$FILL^BSDX41(10-$L(BSDXTMP))_APCHSFAC
I APCHSDCX,APCHSDPR S BSDXTMP=BSDXTMP_$$FILL^BSDX41(23-$L(BSDXTMP))_$E(APCHSCLI,1,6) S BSDXTMP=BSDXTMP_$$FILL^BSDX41(30-$L(BSDXTMP))_APCHSPRV
I APCHSDCX,'APCHSDPR S BSDXTMP=BSDXTMP_$$FILL^BSDX41(23-$L(BSDXTMP))_APCHSCLI
I 'APCHSDCX,APCHSDPR S BSDXTMP=BSDXTMP_$$FILL^BSDX41(23-$L(BSDXTMP))_APCHSPRV
S APCHSICL=APCHSDCL
S:0 APCHSICD=APCHSVSC_":"_APCHSICD D PRTICD^BSDX41F
Q
INHOSP ; ********** INHOSPITAL ENCOUNTERS * 9000010/9000010.07 **********
; <SETUP>
Q:'$D(^AUPNVSIT("AA",APCHSPAT))
S APCHSOVT="I" ; NOTE: This controls types of visits displayed
;X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
; <DISPLAY>
S APCHSDCX="",APCHSDPR=""
I $D(^APCHSCTL(APCHSTYP,2)),$P(^(2),U,3)="Y" S APCHSDCX=1
I $D(^APCHSCTL(APCHSTYP,2)),$P(^(2),U,5)=1 S APCHSDPR=1
I 'APCHSDPR,'APCHSDCX S APCHSDCL=23
I APCHSDCX,'APCHSDPR S APCHSDCL=32
I APCHSDCX,APCHSDPR S APCHSDCL=35
I 'APCHSDCX,APCHSDPR S APCHSDCL=28
S APCHSPVD=0
F APCHSIVD=0:0 S APCHSIVD=$O(^AUPNVSIT("AA",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) D ONEDATE Q:$D(APCHSQIT) S:(APCHSDAT'=APCHSPVD)&APCHSDTU APCHSNDM=APCHSNDM-APCHSDTU,APCHSPVD=APCHSDAT Q:APCHSNDM=0
; <CLEANUP>
INHOSPX K APCHSIVD,APCHSDTU,APCHSDAT,APCHSVDF,APCHSFAC,APCHSPFN,APCHSSCL,APCHSMTX,APCHSMOD,APCHSPVD,APCHSOVT,APCHSNDT,APCHSCLI,APCHSPDN,APCHSICD,APCHSICL,APCHSNRQ
K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE,Y
Q
;
GETSITEV ;ENTRY POINT
S APCHSP=^AUPNVSIT(APCHSVDF,0),APCHSVSC=$P(APCHSP,U,7),APCHSITE=$P(APCHSP,U,6)
GETSITE ;ENTRY POINT
S:APCHSITE="" APCHSITE="null"
S APCHSP=$G(^AUTTLOC(APCHSITE,0))
S:'$D(APCHSVDF) APCHSVDF=-1
;S APCHSNFL=$P(APCHSP,U,1),APCHSNFL=$S($D(^DIC(4,APCHSNFL,0)):$P(^(0),U,1),$D(^AUPNVSIT(APCHSVDF,21))#2:$P(^(21),U),1:"<"_APCHSITE_">") ;IHS/CMI/LAB - commented out and replaced with line below
S APCHSNFL=$P(APCHSP,U,1) S:APCHSNFL="" APCHSNFL="null" S APCHSNFL=$S($D(^DIC(4,APCHSNFL,0)):$P(^DIC(4,APCHSNFL,0),U,1),$P($G(^AUPNVSIT(APCHSVDF,21)),U)]"":$P(^AUPNVSIT(APCHSVDF,21),U),1:"<"_APCHSITE_">") ;IHS/CMI/LAB - fixed this line
;S APCHSNSH=$P(APCHSP,U,2) S:$D(^AUPNVSIT(APCHSVDF,21))#2 APCHSNSH=$E($P(^(21),U),1,12) I APCHSNSH="" S APCHSNSH="<"_APCHSITE_">" ;IHS/CMI/LAB - commented out
S APCHSNSH=$P(APCHSP,U,2) S:$P($G(^AUPNVSIT(APCHSVDF,21)),U)]"" APCHSNSH=$E($P(^AUPNVSIT(APCHSVDF,21),U),1,12) I APCHSNSH="" S APCHSNSH="<"_APCHSITE_">" ;IHS/CMI/LAB - fixed this line to replace the one above
K:APCHSVDF=-1 APCHSVDF
S APCHSNAB=$J($P(APCHSP,U,7),4) I APCHSNAB="" S APCHSNAB="<"_APCHSITE_">"
Q
;
INPT ; ********** HOSPITALIZATION ENCOUNTERS * 9000010/900010.07 **********
; <SETUP>
Q:'$D(^AUPNVSIT("AAH",APCHSPAT))
;X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
; <DISPLAY>
S APCHSPVD=0
S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVSIT("AAH",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) D IONEDATE Q:$D(APCHSQIT) S:APCHSDAT'=APCHSPVD APCHSNDM=APCHSNDM-1,APCHSPVD=APCHSDAT Q:APCHSNDM=0
; <CLEANUP>
INPTX K APCHSIVD,APCHSDTU,APCHSDAT,APCHSVDF,APCHSFAC,APCHSFO,APCHSMTX,APCHSMOD,APCHSPVD,APCHSHDN,APCHSDDC,APCHSCDN,APCHSICD,APCHSICL,APCHSN,APCHSNRQ,APCHSPDN,APCHSVTP
K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE,Y,APCHSIVD,APCHCSVD
Q
IONEDATE S (Y,APCHCSVD)=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y S APCHSDTU=(APCHSDAT=APCHSPVD)
S APCHSVDF="" F APCHSQ=0:0 S APCHSVDF=$O(^AUPNVSIT("AAH",APCHSPAT,APCHSIVD,APCHSVDF)) Q:APCHSVDF="" S APCHSN=^AUPNVSIT(APCHSVDF,0) D GETSITEV D:"H"[APCHSVSC HOSP Q:$D(APCHSQIT)
Q
;
HOSP ;
Q:$P(APCHSN,U,9)=0!($P(APCHSN,U,11)=1)
S APCHSVTP=$P(APCHSN,U,3)
S APCHSDTU=1
S APCHSFAC=APCHSNSH
S APCHSDDC="?"
I APCHSVTP'="C" S APCHSHDN=$O(^AUPNVINP("AD",APCHSVDF,0)) I APCHSHDN S Y=+^AUPNVINP(APCHSHDN,0) X APCHSCVD S APCHSDDC=Y
I APCHSVTP="C" S APCHSCDN=$O(^AUPNVCHS("AD",APCHSVDF,0)) I APCHSCDN S Y=$P(^AUPNVCHS(APCHSCDN,0),U,7) X APCHSCVD S APCHSDDC=Y
X APCHSCKP Q:$D(APCHSQIT)
D IHDR
S APCHSPDN="" F APCHSQ=0:0 S APCHSPDN=$O(^AUPNVPOV("AD",APCHSVDF,APCHSPDN)) Q:'APCHSPDN S APCHSN=^AUPNVPOV(APCHSPDN,0) D DSPPOV
I $X S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(32)_"<no visit data>"_$C(30)
Q
;
DSPPOV S APCHSICD=$P(APCHSN,U,1) D GETICDDX^APCHSUTL
S APCHSNRQ=$P(APCHSN,U,4)
D GETNARR^APCHSUTL
S APCHSMOD=$P(APCHSN,U,6)
I APCHSMOD]"" S APCHSMTX=$P(^DD(9000010.07,.06,0),U,3),APCHSMTX=$P($P(APCHSMTX,APCHSMOD_":",2),";",1),APCHSMTX=$P(APCHSMTX,",",1),APCHSICD=APCHSMTX_" "_APCHSICD
S:$D(^AUPNVCHS("AD",APCHSVDF)) APCHSNTE="*** CHS ***"
;X APCHSCKP Q:$D(APCHSQIT)
D:APCHSNPG IHDR S APCHSICL=33 S:0 APCHSICD=APCHSVSC_":"_APCHSICD D PRTICD^BSDX41F
Q
;
IHDR S BSDXTMP=APCHSDAT_"-"_APCHSDDC
S BSDXTMP=BSDXTMP_$$FILL^BSDX41(18-$L(BSDXTMP))_APCHSFAC
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
S BSDXTMP=""
Q
;
SCHENC ; ********** SCHEDULED ENCOUNTERS * 2/44 ********** (APCHS2D)
; <SETUP>
Q:'$D(^DPT(APCHSPAT,"S"))
;X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
; <DISPLAY>
S APCHSI=$O(^DPT(APCHSPAT,"S",0)) I APCHSI,APCHSI<DT D PAST
D:$O(^DPT(APCHSPAT,"S",DT)) PEND
; <CLEANUP>
SCHENCX K APCHSVDT,APCHSVD1,APCHSIVD,APCHSDAT,APCHSPVD,APCHSN,APCHSVT,APCHSCN,APCHSCP,APCHSTST,APCHSI,APCHSJ,APCHSET,APCHSHP,APCHSVN,APCHSVNT,Y
Q
;
PAST ;
K ^TMP($J,"APCHS")
S APCHSVD1=9999999-APCHSDLM,APCHSDAT=0,APCHSI=0
S APCHSVDT=APCHSVD1 F APCHSQ=0:0 S APCHSVDT=$O(^DPT(APCHSPAT,"S",APCHSVDT)) Q:'APCHSVDT!(APCHSVDT>DT) D ADDONE
Q:'$O(^TMP($J,"APCHS",""))
S APCHSET="PAST:"
;X APCHSCKP Q:$D(APCHSQIT)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=APCHSET_$C(30)
S APCHSIVD=0 F APCHSQ=0:0 S APCHSIVD=$O(^TMP($J,"APCHS",APCHSIVD)) Q:'APCHSIVD S APCHSVDT=^(APCHSIVD) D ONEVIS Q:$D(APCHSQIT)
K ^TMP($J,"APCHS")
Q
;
ADDONE S APCHSIVD=9999999.9999-APCHSVDT
S APCHSI=APCHSI+1,^TMP($J,"APCHS",APCHSIVD)=APCHSVDT,^TMP($J,"APCHS","B",APCHSVDT)=""
I APCHSNDM>0,APCHSI>APCHSNDM S APCHSI=APCHSI-1,APCHSJ=$O(^TMP($J,"APCHS","B","")) K ^(APCHSJ) K ^TMP($J,"APCHS",9999999.9999-APCHSJ)
Q
PEND ;
S APCHSET="PENDING:"
;X APCHSCKP Q:$D(APCHSQIT)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=APCHSET_$C(30)
S APCHSDAT=0,APCHSVDT=DT-.01 F APCHSQ=0:0 S APCHSVDT=$O(^DPT(APCHSPAT,"S",APCHSVDT)) Q:'APCHSVDT D ONEVIS Q:$D(APCHSQIT)
Q
;
ONEVIS S APCHSN=^DPT(APCHSPAT,"S",APCHSVDT,0)
Q:"CP"[$E($P(APCHSN,U,2)_" ")
S APCHSAM="am"
;Q:$P(APCHSN,U,7)=4 ;skip unscheduled
I APCHSVDT\1'=APCHSDAT S Y=APCHSVDT\1 X APCHSCVD S (APCHSPVD,APCHSDAT)=Y,APCHSNDM=APCHSNDM-1
S APCHSVT=$E($P(APCHSVDT,".",2)_"000",1,4) S:APCHSVT>1159 APCHSAM="pm" S:APCHSVT>1300 APCHSVT=APCHSVT-1200 S:$L(APCHSVT)=3 APCHSVT=" "_APCHSVT S:$E(APCHSVT)="0" APCHSVT=" "_$E(APCHSVT,2,4) S APCHSVT=$E(APCHSVT,1,2)_":"_$E(APCHSVT,3,4)
S APCHSTST="" F APCHSI=3,4,5 S APCHSJ=$P(APCHSN,U,APCHSI) I APCHSJ S:APCHSTST]"" APCHSTST=APCHSTST_"," S APCHSTST=APCHSTST_$P("^^LAB^XRAY^EKG^",U,APCHSI)
S APCHSCP=+APCHSN,APCHSCN=$P($G(^SC(APCHSCP,0)),U,1) Q:APCHSCN=""
S APCHSTST="",APCHSVNT=""
S APCHSVN=0 F APCHSQ=0:0 S APCHSVN=$O(^SC(APCHSCP,"S",APCHSVDT,1,APCHSVN)) Q:'APCHSVN I +^(APCHSVN,0)=APCHSPAT S APCHSTST=$P(^(0),U,2),APCHSVNT=$P(^(0),U,4) S:APCHSTST APCHSTST=APCHSTST_" min."
F APCHSI=3,4,5 S APCHSJ=$P(APCHSN,U,APCHSI) I APCHSJ S:APCHSTST]"" APCHSTST=APCHSTST_"," S APCHSTST=APCHSTST_$P("^^LAB^XRAY^EKG^",U,APCHSI)
D L1
I APCHSVNT]"" D
.;X APCHSCKP Q:$D(APCHSQIT)
.D:APCHSNPG L1 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(19)_APCHSVNT_$C(30)
Q
L1 ;X APCHSCKP Q:$D(APCHSQIT)
I APCHSNPG S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=APCHSET_$C(30) S APCHSDAT=APCHSPVD
S BSDXTMP=" "_APCHSDAT
S BSDXTMP=BSDXTMP_$$FILL^BSDX41(11-$L(BSDXTMP))_APCHSVT_APCHSAM
S BSDXTMP=BSDXTMP_$$FILL^BSDX41(20-$L(BSDXTMP))_APCHSCN
I APCHSTST]"" S BSDXTMP=BSDXTMP_" ("_APCHSTST_")"
I $P(APCHSN,U,2)["N" S BSDXTMP=BSDXTMP_$$FILL^BSDX41(37-$L(BSDXTMP))_"*** DNKA ***"
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
Q
BSDX41I ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
+1 ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
+2 ;
OUTPT ; ********** OUTPATIENT ENCOUNTERS * 9000010/9000010.07 **********
+1 ; <SETUP>
+2 IF '$DATA(^AUPNVSIT("AA",APCHSPAT))
QUIT
+3 ; NOTE: THIS CONTROLS TYPES OF VISITS DISPLAYED
SET APCHSOVT="ARSCOTE"
+4 ;X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
+5 ; <DISPLAY>
+6 SET APCHSPVD=0
+7 SET APCHSPFN=""
+8 SET APCHSDCX=""
SET APCHSDPR=""
+9 IF $DATA(^APCHSCTL(APCHSTYP,2))
IF $PIECE(^(2),U,3)="Y"
SET APCHSDCX=1
+10 IF $DATA(^APCHSCTL(APCHSTYP,2))
IF $PIECE(^(2),U,5)=1
SET APCHSDPR=1
+11 IF 'APCHSDPR
IF 'APCHSDCX
SET APCHSDCL=23
+12 IF APCHSDCX
IF 'APCHSDPR
SET APCHSDCL=32
+13 IF APCHSDCX
IF APCHSDPR
SET APCHSDCL=35
+14 IF 'APCHSDCX
IF APCHSDPR
SET APCHSDCL=28
+15 SET APCHSICF=$SELECT('$DATA(APCHSTYP):"L",'$DATA(^APCHSCTL(APCHSTYP,2)):"L",$PIECE(^APCHSCTL(APCHSTYP,2),U,1)]"":$PIECE(^APCHSCTL(APCHSTYP,2),U,1),1:"L")
+16 FOR APCHSIVD=0:0
SET APCHSIVD=$ORDER(^AUPNVSIT("AA",APCHSPAT,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
Begin DoDot:1
+17 SET APCHSQT=1
+18 DO ONEDATE
+19 IF $DATA(APCHSQIT)
QUIT
+20 IF (APCHSDAT'=APCHSPVD)&APCHSDTU
SET APCHSNDM=APCHSNDM-APCHSDTU
SET APCHSPVD=APCHSDAT
+21 SET APCHSQT=0
+22 QUIT
End DoDot:1
IF APCHSNDM=0!(APCHSQT)
QUIT
+23 ;
OUTPTX ; <CLEANUP>
+1 KILL APCHSIVD,APCHSDTU,APCHSDAT,APCHSVDF,APCHSFAC,APCHSPFN,APCHSSCL,APCHSMTX,APCHSMOD,APCHSPVD,APCHSOVT,APCHSNDT,APCHSCLI,APCHSPDN,APCHSICD,APCHSICL,APCHSNRQ,APCHSDPR,APCHSDCX
+2 KILL APCHSNFL,APCHSNSH,APCHSCCL,APCHSNAB,APCHSVSC,APCHSITE,APCHSQT,APCHSDCL,Y,APCHCSVD
+3 QUIT
+4 ;
ONEDATE ;
+1 SET APCHSCCL=""
+2 SET (Y,APCHCSVD)=-APCHSIVD\1+9999999
XECUTE APCHSCVD
SET APCHSDAT=Y
+3 ;S (APCHSPFN,APCHSSCL)="",APCHSDTU=0,APCHSNDT=(APCHSDAT'=APCHSPVD)
+4 SET APCHSDTU=0
SET APCHSNDT=(APCHSDAT'=APCHSPVD)
+5 SET APCHSVDF=""
FOR APCHSQ=0:0
SET APCHSVDF=$ORDER(^AUPNVSIT("AA",APCHSPAT,APCHSIVD,APCHSVDF))
IF APCHSVDF=""
QUIT
Begin DoDot:1
+6 SET APCHSQT=1
+7 SET APCHSSCL=""
+8 SET APCHSN=^AUPNVSIT(APCHSVDF,0)
+9 ;don't display events with no pov
IF $PIECE(APCHSN,U,7)="E"
IF '$DATA(^AUPNVPOV("AD",APCHSVDF))
SET APCHSQT=0
QUIT
+10 ;don't display in hosp visits with no pov
IF $PIECE(APCHSN,U,7)="I"
IF '$DATA(^AUPNVPOV("AD",APCHSVDF))
SET APCHSQT=0
QUIT
+11 IF +$PIECE(APCHSN,U,9)
IF '$PIECE(APCHSN,U,11)
DO GETCLN
DO GETPROV
DO GETSITEV
Begin DoDot:2
+12 IF APCHSOVT[APCHSVSC
DO DSPVIS
+13 QUIT
End DoDot:2
+14 IF $DATA(APCHSQIT)
QUIT
+15 SET APCHSQT=0
+16 QUIT
End DoDot:1
IF APCHSQT
QUIT
+17 QUIT
+18 ;
GETPROV ;
+1 SET APCHSPRV=$$PRIMPROV^APCLV(APCHSVDF,"T")
+2 QUIT
GETCLN ;
+1 SET APCHSCLI=$PIECE(APCHSN,U,8)
IF APCHSCLI=""
SET APCHSCCL="<none>"
QUIT
+2 SET APCHSCLI=$PIECE(APCHSN,U,8)
IF APCHSCLI=""
QUIT
+3 IF '$DATA(^DIC(40.7,APCHSCLI))
QUIT
+4 IF $DATA(^DIC(40.7,APCHSCLI,9999999))
IF $PIECE(^(9999999),U,1)]""
SET APCHSCLI=$EXTRACT($PIECE(^DIC(40.7,APCHSCLI,9999999),U,1),1,6)
SET APCHSCCL=APCHSCLI
QUIT
+5 SET APCHSCLI=$EXTRACT($PIECE(^DIC(40.7,APCHSCLI,0),U,1),1,8)
+6 SET APCHSCCL=APCHSCLI
+7 QUIT
DSPVIS ;
+1 SET APCHSDTU=1
+2 IF $ORDER(^AUPNVPOV("AD",APCHSVDF,""))=""
DO NOPOV
QUIT
+3 SET APCHSPDN=""
FOR APCHSQ=0:0
SET APCHSPDN=$ORDER(^AUPNVPOV("AD",APCHSVDF,APCHSPDN))
IF 'APCHSPDN
QUIT
SET APCHSN=^AUPNVPOV(APCHSPDN,0)
DO HASPOV
+4 QUIT
+5 ;
NOPOV ;
+1 SET (APCHSICD,APCHSNRQ)="<purpose of visit not yet entered>"
SET APCHSMOD=""
+2 GOTO COMMON
+3 ;
HASPOV ;
+1 SET APCHSICD=$PIECE(APCHSN,U,1)
DO GETICDDX^APCHSUTL
+2 ;IHS/CMI/LAB - patched to display stage of 0
SET APCHSNRQ=$PIECE(APCHSN,U,4)
DO GETNARR^APCHSUTL
IF $PIECE(APCHSN,U,5)]""
SET APCHSNRQ=APCHSNRQ_" (Stage: "_$PIECE(APCHSN,U,5)_")"
+3 SET APCHSMOD=$PIECE(APCHSN,U,6)
COMMON ;
+1 ;X APCHSCKP Q:$D(APCHSQIT) S:APCHSNPG APCHSNDT=1
+2 IF APCHSNDT
SET BSDXTMP=APCHSDAT
SET (APCHSPFN,APCHSSCL)=""
SET APCHSNDT=0
+3 IF APCHSNSH=APCHSPFN
SET APCHSFAC=""
+4 IF '$TEST
SET (APCHSFAC,APCHSPFN)=APCHSNSH
SET APCHSSCL=""
+5 IF APCHSCCL=APCHSSCL
SET APCHSCLI=""
+6 IF '$TEST
SET (APCHSCLI,APCHSSCL)=APCHSCCL
+7 IF APCHSICD["<purpose of visit not"&(APCHSSCL="<none>")
SET APCHSCLI=""
+8 IF APCHSMOD]""
SET APCHSMTX=$PIECE(^DD(9000010.07,.06,0),U,3)
SET APCHSMTX=$PIECE($PIECE(APCHSMTX,APCHSMOD_":",2),";",1)
SET APCHSMTX=$PIECE(APCHSMTX,",",1)
SET APCHSICD=APCHSMTX_" "_APCHSICD
+9 IF $DATA(^AUPNVCHS("AD",APCHSVDF))
SET APCHSNTE="*** CHS ***"
+10 ;S APCHSICL=$S(APCHSCLI'=" ":35,1:23)
+11 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(10-$LENGTH(BSDXTMP))_APCHSFAC
+12 IF APCHSDCX
IF APCHSDPR
SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(23-$LENGTH(BSDXTMP))_$EXTRACT(APCHSCLI,1,6)
SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(30-$LENGTH(BSDXTMP))_APCHSPRV
+13 IF APCHSDCX
IF 'APCHSDPR
SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(23-$LENGTH(BSDXTMP))_APCHSCLI
+14 IF 'APCHSDCX
IF APCHSDPR
SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(23-$LENGTH(BSDXTMP))_APCHSPRV
+15 SET APCHSICL=APCHSDCL
+16 IF 0
SET APCHSICD=APCHSVSC_":"_APCHSICD
DO PRTICD^BSDX41F
+17 QUIT
INHOSP ; ********** INHOSPITAL ENCOUNTERS * 9000010/9000010.07 **********
+1 ; <SETUP>
+2 IF '$DATA(^AUPNVSIT("AA",APCHSPAT))
QUIT
+3 ; NOTE: This controls types of visits displayed
SET APCHSOVT="I"
+4 ;X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
+5 ; <DISPLAY>
+6 SET APCHSDCX=""
SET APCHSDPR=""
+7 IF $DATA(^APCHSCTL(APCHSTYP,2))
IF $PIECE(^(2),U,3)="Y"
SET APCHSDCX=1
+8 IF $DATA(^APCHSCTL(APCHSTYP,2))
IF $PIECE(^(2),U,5)=1
SET APCHSDPR=1
+9 IF 'APCHSDPR
IF 'APCHSDCX
SET APCHSDCL=23
+10 IF APCHSDCX
IF 'APCHSDPR
SET APCHSDCL=32
+11 IF APCHSDCX
IF APCHSDPR
SET APCHSDCL=35
+12 IF 'APCHSDCX
IF APCHSDPR
SET APCHSDCL=28
+13 SET APCHSPVD=0
+14 FOR APCHSIVD=0:0
SET APCHSIVD=$ORDER(^AUPNVSIT("AA",APCHSPAT,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
DO ONEDATE
IF $DATA(APCHSQIT)
QUIT
IF (APCHSDAT'=APCHSPVD)&APCHSDTU
SET APCHSNDM=APCHSNDM-APCHSDTU
SET APCHSPVD=APCHSDAT
IF APCHSNDM=0
QUIT
+15 ; <CLEANUP>
INHOSPX KILL APCHSIVD,APCHSDTU,APCHSDAT,APCHSVDF,APCHSFAC,APCHSPFN,APCHSSCL,APCHSMTX,APCHSMOD,APCHSPVD,APCHSOVT,APCHSNDT,APCHSCLI,APCHSPDN,APCHSICD,APCHSICL,APCHSNRQ
+1 KILL APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE,Y
+2 QUIT
+3 ;
GETSITEV ;ENTRY POINT
+1 SET APCHSP=^AUPNVSIT(APCHSVDF,0)
SET APCHSVSC=$PIECE(APCHSP,U,7)
SET APCHSITE=$PIECE(APCHSP,U,6)
GETSITE ;ENTRY POINT
+1 IF APCHSITE=""
SET APCHSITE="null"
+2 SET APCHSP=$GET(^AUTTLOC(APCHSITE,0))
+3 IF '$DATA(APCHSVDF)
SET APCHSVDF=-1
+4 ;S APCHSNFL=$P(APCHSP,U,1),APCHSNFL=$S($D(^DIC(4,APCHSNFL,0)):$P(^(0),U,1),$D(^AUPNVSIT(APCHSVDF,21))#2:$P(^(21),U),1:"<"_APCHSITE_">") ;IHS/CMI/LAB - commented out and replaced with line below
+5 ;IHS/CMI/LAB - fixed this line
SET APCHSNFL=$PIECE(APCHSP,U,1)
IF APCHSNFL=""
SET APCHSNFL="null"
SET APCHSNFL=$SELECT($DATA(^DIC(4,APCHSNFL,0)):$PIECE(^DIC(4,APCHSNFL,0),U,1),$PIECE($GET(^AUPNVSIT(APCHSVDF,21)),U)]"":$PIECE(^AUPNVSIT(APCHSVDF,21),U),1:"<"_APCHSITE_">")
+6 ;S APCHSNSH=$P(APCHSP,U,2) S:$D(^AUPNVSIT(APCHSVDF,21))#2 APCHSNSH=$E($P(^(21),U),1,12) I APCHSNSH="" S APCHSNSH="<"_APCHSITE_">" ;IHS/CMI/LAB - commented out
+7 ;IHS/CMI/LAB - fixed this line to replace the one above
SET APCHSNSH=$PIECE(APCHSP,U,2)
IF $PIECE($GET(^AUPNVSIT(APCHSVDF,21)),U)]""
SET APCHSNSH=$EXTRACT($PIECE(^AUPNVSIT(APCHSVDF,21),U),1,12)
IF APCHSNSH=""
SET APCHSNSH="<"_APCHSITE_">"
+8 IF APCHSVDF=-1
KILL APCHSVDF
+9 SET APCHSNAB=$JUSTIFY($PIECE(APCHSP,U,7),4)
IF APCHSNAB=""
SET APCHSNAB="<"_APCHSITE_">"
+10 QUIT
+11 ;
INPT ; ********** HOSPITALIZATION ENCOUNTERS * 9000010/900010.07 **********
+1 ; <SETUP>
+2 IF '$DATA(^AUPNVSIT("AAH",APCHSPAT))
QUIT
+3 ;X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
+4 ; <DISPLAY>
+5 SET APCHSPVD=0
+6 SET APCHSIVD=""
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^AUPNVSIT("AAH",APCHSPAT,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
DO IONEDATE
IF $DATA(APCHSQIT)
QUIT
IF APCHSDAT'=APCHSPVD
SET APCHSNDM=APCHSNDM-1
SET APCHSPVD=APCHSDAT
IF APCHSNDM=0
QUIT
+7 ; <CLEANUP>
INPTX KILL APCHSIVD,APCHSDTU,APCHSDAT,APCHSVDF,APCHSFAC,APCHSFO,APCHSMTX,APCHSMOD,APCHSPVD,APCHSHDN,APCHSDDC,APCHSCDN,APCHSICD,APCHSICL,APCHSN,APCHSNRQ,APCHSPDN,APCHSVTP
+1 KILL APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE,Y,APCHSIVD,APCHCSVD
+2 QUIT
IONEDATE SET (Y,APCHCSVD)=-APCHSIVD\1+9999999
XECUTE APCHSCVD
SET APCHSDAT=Y
SET APCHSDTU=(APCHSDAT=APCHSPVD)
+1 SET APCHSVDF=""
FOR APCHSQ=0:0
SET APCHSVDF=$ORDER(^AUPNVSIT("AAH",APCHSPAT,APCHSIVD,APCHSVDF))
IF APCHSVDF=""
QUIT
SET APCHSN=^AUPNVSIT(APCHSVDF,0)
DO GETSITEV
IF "H"[APCHSVSC
DO HOSP
IF $DATA(APCHSQIT)
QUIT
+2 QUIT
+3 ;
HOSP ;
+1 IF $PIECE(APCHSN,U,9)=0!($PIECE(APCHSN,U,11)=1)
QUIT
+2 SET APCHSVTP=$PIECE(APCHSN,U,3)
+3 SET APCHSDTU=1
+4 SET APCHSFAC=APCHSNSH
+5 SET APCHSDDC="?"
+6 IF APCHSVTP'="C"
SET APCHSHDN=$ORDER(^AUPNVINP("AD",APCHSVDF,0))
IF APCHSHDN
SET Y=+^AUPNVINP(APCHSHDN,0)
XECUTE APCHSCVD
SET APCHSDDC=Y
+7 IF APCHSVTP="C"
SET APCHSCDN=$ORDER(^AUPNVCHS("AD",APCHSVDF,0))
IF APCHSCDN
SET Y=$PIECE(^AUPNVCHS(APCHSCDN,0),U,7)
XECUTE APCHSCVD
SET APCHSDDC=Y
+8 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+9 DO IHDR
+10 SET APCHSPDN=""
FOR APCHSQ=0:0
SET APCHSPDN=$ORDER(^AUPNVPOV("AD",APCHSVDF,APCHSPDN))
IF 'APCHSPDN
QUIT
SET APCHSN=^AUPNVPOV(APCHSPDN,0)
DO DSPPOV
+11 IF $X
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$$FILL^BSDX41(32)_"<no visit data>"_$CHAR(30)
+12 QUIT
+13 ;
DSPPOV SET APCHSICD=$PIECE(APCHSN,U,1)
DO GETICDDX^APCHSUTL
+1 SET APCHSNRQ=$PIECE(APCHSN,U,4)
+2 DO GETNARR^APCHSUTL
+3 SET APCHSMOD=$PIECE(APCHSN,U,6)
+4 IF APCHSMOD]""
SET APCHSMTX=$PIECE(^DD(9000010.07,.06,0),U,3)
SET APCHSMTX=$PIECE($PIECE(APCHSMTX,APCHSMOD_":",2),";",1)
SET APCHSMTX=$PIECE(APCHSMTX,",",1)
SET APCHSICD=APCHSMTX_" "_APCHSICD
+5 IF $DATA(^AUPNVCHS("AD",APCHSVDF))
SET APCHSNTE="*** CHS ***"
+6 ;X APCHSCKP Q:$D(APCHSQIT)
+7 IF APCHSNPG
DO IHDR
SET APCHSICL=33
IF 0
SET APCHSICD=APCHSVSC_":"_APCHSICD
DO PRTICD^BSDX41F
+8 QUIT
+9 ;
IHDR SET BSDXTMP=APCHSDAT_"-"_APCHSDDC
+1 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(18-$LENGTH(BSDXTMP))_APCHSFAC
+2 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
+3 SET BSDXTMP=""
+4 QUIT
+5 ;
SCHENC ; ********** SCHEDULED ENCOUNTERS * 2/44 ********** (APCHS2D)
+1 ; <SETUP>
+2 IF '$DATA(^DPT(APCHSPAT,"S"))
QUIT
+3 ;X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
+4 ; <DISPLAY>
+5 SET APCHSI=$ORDER(^DPT(APCHSPAT,"S",0))
IF APCHSI
IF APCHSI<DT
DO PAST
+6 IF $ORDER(^DPT(APCHSPAT,"S",DT))
DO PEND
+7 ; <CLEANUP>
SCHENCX KILL APCHSVDT,APCHSVD1,APCHSIVD,APCHSDAT,APCHSPVD,APCHSN,APCHSVT,APCHSCN,APCHSCP,APCHSTST,APCHSI,APCHSJ,APCHSET,APCHSHP,APCHSVN,APCHSVNT,Y
+1 QUIT
+2 ;
PAST ;
+1 KILL ^TMP($JOB,"APCHS")
+2 SET APCHSVD1=9999999-APCHSDLM
SET APCHSDAT=0
SET APCHSI=0
+3 SET APCHSVDT=APCHSVD1
FOR APCHSQ=0:0
SET APCHSVDT=$ORDER(^DPT(APCHSPAT,"S",APCHSVDT))
IF 'APCHSVDT!(APCHSVDT>DT)
QUIT
DO ADDONE
+4 IF '$ORDER(^TMP($JOB,"APCHS",""))
QUIT
+5 SET APCHSET="PAST:"
+6 ;X APCHSCKP Q:$D(APCHSQIT)
+7 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=APCHSET_$CHAR(30)
+8 SET APCHSIVD=0
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^TMP($JOB,"APCHS",APCHSIVD))
IF 'APCHSIVD
QUIT
SET APCHSVDT=^(APCHSIVD)
DO ONEVIS
IF $DATA(APCHSQIT)
QUIT
+9 KILL ^TMP($JOB,"APCHS")
+10 QUIT
+11 ;
ADDONE SET APCHSIVD=9999999.9999-APCHSVDT
+1 SET APCHSI=APCHSI+1
SET ^TMP($JOB,"APCHS",APCHSIVD)=APCHSVDT
SET ^TMP($JOB,"APCHS","B",APCHSVDT)=""
+2 IF APCHSNDM>0
IF APCHSI>APCHSNDM
SET APCHSI=APCHSI-1
SET APCHSJ=$ORDER(^TMP($JOB,"APCHS","B",""))
KILL ^(APCHSJ)
KILL ^TMP($JOB,"APCHS",9999999.9999-APCHSJ)
+3 QUIT
PEND ;
+1 SET APCHSET="PENDING:"
+2 ;X APCHSCKP Q:$D(APCHSQIT)
+3 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=APCHSET_$CHAR(30)
+4 SET APCHSDAT=0
SET APCHSVDT=DT-.01
FOR APCHSQ=0:0
SET APCHSVDT=$ORDER(^DPT(APCHSPAT,"S",APCHSVDT))
IF 'APCHSVDT
QUIT
DO ONEVIS
IF $DATA(APCHSQIT)
QUIT
+5 QUIT
+6 ;
ONEVIS SET APCHSN=^DPT(APCHSPAT,"S",APCHSVDT,0)
+1 IF "CP"[$EXTRACT($PIECE(APCHSN,U,2)_" ")
QUIT
+2 SET APCHSAM="am"
+3 ;Q:$P(APCHSN,U,7)=4 ;skip unscheduled
+4 IF APCHSVDT\1'=APCHSDAT
SET Y=APCHSVDT\1
XECUTE APCHSCVD
SET (APCHSPVD,APCHSDAT)=Y
SET APCHSNDM=APCHSNDM-1
+5 SET APCHSVT=$EXTRACT($PIECE(APCHSVDT,".",2)_"000",1,4)
IF APCHSVT>1159
SET APCHSAM="pm"
IF APCHSVT>1300
SET APCHSVT=APCHSVT-1200
IF $LENGTH(APCHSVT)=3
SET APCHSVT=" "_APCHSVT
IF $EXTRACT(APCHSVT)="0"
SET APCHSVT=" "_$EXTRACT(APCHSVT,2,4)
SET APCHSVT=$EXTRACT(APCHSVT,1,2)_":"_$EXTRACT(APCHSVT,3,4)
+6 SET APCHSTST=""
FOR APCHSI=3,4,5
SET APCHSJ=$PIECE(APCHSN,U,APCHSI)
IF APCHSJ
IF APCHSTST]""
SET APCHSTST=APCHSTST_","
SET APCHSTST=APCHSTST_$PIECE("^^LAB^XRAY^EKG^",U,APCHSI)
+7 SET APCHSCP=+APCHSN
SET APCHSCN=$PIECE($GET(^SC(APCHSCP,0)),U,1)
IF APCHSCN=""
QUIT
+8 SET APCHSTST=""
SET APCHSVNT=""
+9 SET APCHSVN=0
FOR APCHSQ=0:0
SET APCHSVN=$ORDER(^SC(APCHSCP,"S",APCHSVDT,1,APCHSVN))
IF 'APCHSVN
QUIT
IF +^(APCHSVN,0)=APCHSPAT
SET APCHSTST=$PIECE(^(0),U,2)
SET APCHSVNT=$PIECE(^(0),U,4)
IF APCHSTST
SET APCHSTST=APCHSTST_" min."
+10 FOR APCHSI=3,4,5
SET APCHSJ=$PIECE(APCHSN,U,APCHSI)
IF APCHSJ
IF APCHSTST]""
SET APCHSTST=APCHSTST_","
SET APCHSTST=APCHSTST_$PIECE("^^LAB^XRAY^EKG^",U,APCHSI)
+11 DO L1
+12 IF APCHSVNT]""
Begin DoDot:1
+13 ;X APCHSCKP Q:$D(APCHSQIT)
+14 IF APCHSNPG
DO L1
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$$FILL^BSDX41(19)_APCHSVNT_$CHAR(30)
End DoDot:1
+15 QUIT
L1 ;X APCHSCKP Q:$D(APCHSQIT)
+1 IF APCHSNPG
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=APCHSET_$CHAR(30)
SET APCHSDAT=APCHSPVD
+2 SET BSDXTMP=" "_APCHSDAT
+3 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(11-$LENGTH(BSDXTMP))_APCHSVT_APCHSAM
+4 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(20-$LENGTH(BSDXTMP))_APCHSCN
+5 IF APCHSTST]""
SET BSDXTMP=BSDXTMP_" ("_APCHSTST_")"
+6 IF $PIECE(APCHSN,U,2)["N"
SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(37-$LENGTH(BSDXTMP))_"*** DNKA ***"
+7 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
+8 QUIT
