BSDX41J ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
;
MRL ; ******************** MOST RECENT LAB * 9000010.09 *******
I '$D(^AUPNVLAB("AA",APCHSPAT)) D EKGLAB G MRLX
;X APCHSCKP Q:$D(APCHSQIT)
;X:'APCHSNPG APCHSBRK
; <SETUP>
; <PROCESS>
D LBLD,LPRT
D EKGLAB
;now display lab refusals
S APCHST="LAB",APCHSFN=60 D DISPREF^BSDX41F
K APCHST,APCHSFN
; <CLEANUP>
MRLX K APCHSLT,APCHSLR,APCHSLTX,APCHSLRT,APCHSLL,APCHSLW,APCHSNMX,APCHSDFN,APCHSIVD,APCHSLTD,APCHSN,Y
K ^TMP($J,"APCHS"),^TMP($J,"APCHS1")
Q
; <BUILD>
LBLD K ^TMP($J,"APCHS","LAB"),^TMP($J,"APCHS1")
S APCHSLRT="" F APCHSQ=0:0 S APCHSLRT=$O(^AUPNVLAB("AA",APCHSPAT,APCHSLRT)) Q:APCHSLRT="" D LDATE
D REORDER
Q
REORDER ;reorder by accession, parent and child
S X=0 F S X=$O(^TMP($J,"APCHS","LAB",X)) Q:X'=+X D
.S Y=$P(^TMP($J,"APCHS","LAB",X),U,3)
.S %=$E($P(^AUPNVLAB(Y,0),U,6),1,2) S:%="" %="ZZ"
.S %1=$S($P($G(^AUPNVLAB(Y,12)),U,8)]"":$P(^AUPNVLAB(Y,12),U,8),1:Y)
.S %2=$S($P($G(^AUPNVLAB(Y,12)),U,8)="":0,1:Y)
.S ^TMP($J,"APCHS1",%,%1,%2,X)=^TMP($J,"APCHS","LAB",X)
.Q
K ^TMP($J,"APCHS")
Q
LDATE S APCHSIVD=$O(^AUPNVLAB("AA",APCHSPAT,APCHSLRT,0))
S APCHSDFN=0 F S APCHSDFN=$O(^AUPNVLAB("AA",APCHSPAT,APCHSLRT,APCHSIVD,APCHSDFN)) Q:APCHSDFN'=+APCHSDFN D:APCHSIVD&(APCHSIVD'>APCHSDLM) LSET
Q
LSET ;
S APCHSN=^AUPNVLAB(APCHSDFN,0),APCHSLR=$P(APCHSN,U,4)
I $P($G(^AUPNVLAB(APCHSDFN,11)),U,9)="R",APCHSLR="",$$VALI^XBDIQ1(60,$P(APCHSN,U),999999901) Q ;do not display tests that are resulted, result is null and flag says don't display
I APCHSLR]"",APCHSLR'=" ",$P(APCHSN,U,5)]"" S APCHSLR=APCHSLR_" ("_$P(APCHSN,U,5)_")"
I APCHSLR="",$P($G(^TMP($J,"APCHS","LAB",APCHSLRT)),U,2)]"" Q
S ^TMP($J,"APCHS","LAB",APCHSLRT)=(-APCHSIVD\1+9999999)_U_APCHSLR_U_APCHSDFN S APCHSLTX=$P(^LAB(60,APCHSLRT,0),U,1)
Q
; <PRINT>
LPRT ;
S BSDXTMP=" "_"TEST"
S BSDXTMP=BSDXTMP_$$FILL^BSDX41(22-$L(BSDXTMP))_"RESULT DT/TIME"
S BSDXTMP=BSDXTMP_$$FILL^BSDX41(38-$L(BSDXTMP))_"VISIT"
S BSDXTMP=BSDXTMP_$$FILL^BSDX41(46-$L(BSDXTMP))_"RESULT"
S BSDXTMP=BSDXTMP_$$FILL^BSDX41(59-$L(BSDXTMP))_"UNITS"
S BSDXTMP=BSDXTMP_$$FILL^BSDX41(69-$L(BSDXTMP))_"REF RANGE"
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
S BSDXTMP=""
S APCHSACC="" F S APCHSACC=$O(^TMP($J,"APCHS1",APCHSACC)) Q:APCHSACC=""!($D(APCHSQIT)) D
.S APCHSPAR=0 F S APCHSPAR=$O(^TMP($J,"APCHS1",APCHSACC,APCHSPAR)) Q:APCHSPAR'=+APCHSPAR!($D(APCHSQIT)) D
..S APCHCHIL="" F S APCHCHIL=$O(^TMP($J,"APCHS1",APCHSACC,APCHSPAR,APCHCHIL)) Q:APCHCHIL="" D
...S APCHSLT=$O(^TMP($J,"APCHS1",APCHSACC,APCHSPAR,APCHCHIL,0))
...S APCHSDFN=$P(^TMP($J,"APCHS1",APCHSACC,APCHSPAR,APCHCHIL,APCHSLT),U,3)
...S Y=$P(^TMP($J,"APCHS1",APCHSACC,APCHSPAR,APCHCHIL,APCHSLT),U,1),APCHSLR=$P(^TMP($J,"APCHS1",APCHSACC,APCHSPAR,APCHCHIL,APCHSLT),U,2) X APCHSCVD S APCHSLTD=Y
...D LPRT2
K APCHCHIL,APCHSPAR,APCHSACC,APCHSLT
Q
LPRT2 ;
S APCHSLTX=$P(^LAB(60,APCHSLT,0),U)
S APCHSRDT=$P($G(^AUPNVLAB(APCHSDFN,12)),U,12) I APCHSRDT]"" S APCHSRDT=$$DATE^APCHSMU($P(APCHSRDT,"."))_"@"_$P($P($$FMTE^XLFDT(APCHSRDT),"@",2),":",1,2)
;X APCHSCKP Q:$D(APCHSQIT)
I APCHSNPG D
.S BSDXTMP=" "_"TEST"
.S BSDXTMP=BSDXTMP_$$FILL^BSDX41(22-$L(BSDXTMP))_"RESULT DT/TIME"
.S BSDXTMP=BSDXTMP_$$FILL^BSDX41(38-$L(BSDXTMP))_"VISIT"
.S BSDXTMP=BSDXTMP_$$FILL^BSDX41(46-$L(BSDXTMP))_"RESULT"
.S BSDXTMP=BSDXTMP_$$FILL^BSDX41(59-$L(BSDXTMP))_"UNITS"
.S BSDXTMP=BSDXTMP_$$FILL^BSDX41(69-$L(BSDXTMP))_"REF RANGE"
.S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
S BSDXTMP=""
S:APCHCHIL BSDXTMP=" "
S BSDXTMP=BSDXTMP_$E(APCHSLTX,1,20)
S BSDXTMP=BSDXTMP_$$FILL^BSDX41(22-$L(BSDXTMP))_APCHSRDT
S BSDXTMP=BSDXTMP_$$FILL^BSDX41(37-$L(BSDXTMP))_APCHSLTD
S BSDXTMP=BSDXTMP_$$FILL^BSDX41(46-$L(BSDXTMP))_APCHSLR
S BSDXTMP=BSDXTMP_$$FILL^BSDX41(59-$L(BSDXTMP))_$P($G(^AUPNVLAB(APCHSDFN,11)),U)
I $P($G(^AUPNVLAB(APCHSDFN,11)),U,4)]""!($P($G(^AUPNVLAB(APCHSDFN,11)),U,5)]"") S BSDXTMP=BSDXTMP_$$FILL^BSDX41(69-$L(BSDXTMP))_$P(^AUPNVLAB(APCHSDFN,11),U,4)_"-"_$P(^AUPNVLAB(APCHSDFN,11),U,5)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
I '$P(^APCHSCTL(APCHSTYP,0),U,7) Q
;print out comments per Dorothy
S APCHSX=0 F S APCHSX=$O(^AUPNVLAB(APCHSDFN,21,APCHSX)) Q:APCHSX'=+APCHSX!($D(APCHSQIT)) D
.;X APCHSCKP Q:$D(APCHSQIT)
.S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=^AUPNVLAB(APCHSDFN,21,APCHSX,0)_$C(30)
F APCHSX=1:1:3 Q:$D(APCHSQIT) I $P($G(^AUPNVLAB(APCHSDFN,13)),U,APCHSX)]"" D
.;X APCHSCKP Q:$D(APCHSQIT)
.S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$P(^AUPNVLAB(APCHSDFN,13),U,APCHSX)_$C(30)
Q
;
EKGLAB ;ENTRY POINT - EKG display in most recent lab panel
Q:'$D(^AUPNVDXP("AC",APCHSPAT))
K APCHS
S APCHSERR=$$START1^APCLDF(APCHSPAT_"^LAST DIAGNOSTIC ECG SUMMARY","APCHS(")
G:APCHSERR EKGLABX
; *array APCHS(1)="DATE^RESULT^DIAG PROC^VDIAG PROCEDURE IEN^AUPNVDXP^VISIT IEN"
K APCHSERR
S APCHSIVD=$S($D(APCHS(1)):9999999-$P($P(APCHS(1),U,1),".",1),1:"")
Q:'APCHSIVD!(APCHSIVD>APCHSDLM)
S (APCHSLTX,APCHSLT)="EKG"
S APCHSLRT("EKG")=$P(APCHS(1),U,1)_"^"_$P(APCHS(1),U,2)
D EKGPRT ; computes/prints ekg info
EKGLABX ;
K APCHSERR,APCHS(1)
Q
;
EKGPRT ;computers/prints ekg info
S Y=$P(APCHSLRT(APCHSLT),U,1) X APCHSCVD S APCHSLTD=Y
S APCHSLR=$P(APCHSLRT(APCHSLT),U,2)
S APCHSLR=$S(APCHSLR="N":"NORMAL",APCHSLR="A":"ABNORMAL",APCHSLR="B":"BORDERLINE",1:"<none recorded>") ;IHS/CMI/LAB added borderline
S APCHSLW=$S($G(APCHSLW):APCHSLW,1:28)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=APCHSLTX_$$FILL^BSDX41(APCHSLW-$L(APCHSLTX))_APCHSLTD_" "_APCHSLR_$C(30)
Q
;
MCIS ; *********** MANAGED CARE MIS * 90001
;X APCHSCKP Q:$D(APCHSQIT)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
NEW X
S X="BMCHS" X ^%ZOSF("TEST") I $T G HS ; write mcis summary
G:'$D(^BMCREF("D",APCHSPAT)) MCISX ; exit if no referrals for patient
;X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="<MCIS DISPLAY ROUTINE MISSING!>"_$C(30)
MCISX ;MCIS EXIT
;
HS ;EP-called from health summary
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$CTR^BMC(" <<< RCIS ACTIVE REFERRALS >>> ",80)_$C(30)
I '$D(^BMCREF("AA",APCHSPAT)) D Q
.;X APCHSCKP Q:$D(APCHSQIT)
.S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
.S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="No Referred Care Referral records on file."_$C(30)
.Q
S X1=DT,X2=-365 D C^%DTC S BMCYAGO=X ; date one year ago
I $O(^BMCREF("AA",APCHSPAT,""),-1)<BMCYAGO D Q
.;X APCHSCKP Q:$D(APCHSQIT)
.S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
.S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="No Referred Care Referral records within last year."_$C(30)
.Q
S BMCRDATE=""
F S BMCRDATE=$O(^BMCREF("AA",APCHSPAT,BMCRDATE),-1) Q:BMCRDATE<BMCYAGO!($D(APCHSQIT)) S BMCRIEN=0 F S BMCRIEN=$O(^BMCREF("AA",APCHSPAT,BMCRDATE,BMCRIEN)) Q:'BMCRIEN!($D(APCHSQIT)) D WRTREF
XIT ;
K DIEN,BMCPFH,BMCPFS,BMCPIEN,BMCYAGO,BMCCHSCT,BMCDFN,BMCRDATE,BMCREC,BMCRIEN,BMCRIO,BMCRNUMB,BMCRREC,BMCRSTAT,BMCRTYPE,BMCX,BMCDIEN
Q
;
WRTREF ; WRITE RCIS REFERRAL ENTRY
S BMCRREC=^BMCREF(BMCRIEN,0)
S Y=BMCRIEN
D ^BMCREF
;
Q:BMCRSTAT'="A" ;Quit if Not an Active Referral
;
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
S BSDXTMP="BEGIN DOS: "_$$AVDOS^BMCRLU(BMCRIEN,"C")_" "_$$AVDOS^BMCRLU(BMCRIEN,"E")
S BSDXTMP=BSDXTMP_$$FILL^BSDX41(36-$L(BSDXTMP))_"DISCHARGE CONSULT DT: "_$$FMTE^XLFDT($P(BMCRREC,U,18),"5D")
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
S BSDXTMP=""
S BSDXTMP="DATE REFERRED: "_$$FMTE^XLFDT($P(BMCRREC,U),"5D")
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$$FILL^BSDX41(36-$L(BSDXTMP))_"CHS STATUS: "_$$VAL^XBDIQ1(90001,BMCRIEN,1112)_$C(30)
S BSDXTMP=""
S BMCMCC=""
I $D(^BMCPARM(DUZ(2),4100)) S BMCMCC=$P($G(^BMCPARM(DUZ(2),4100)),U)
I BMCMCC="Y" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(36)_"MCC ACTION: "_$$VAL^XBDIQ1(90001,BMCRIEN,1123)_$C(30)
S BSDXTMP="REFERRED BY: "_$S($P(BMCRREC,U,6):$E($P(^VA(200,$P(BMCRREC,U,6),0),U),1,22),1:"???")
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$$FILL^BSDX41(36-$L(BSDXTMP))_"REFERRED TO: "_$$TOFAC^BMC(BMCRIEN)_$C(30)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="PURPOSE: "_$$VAL^XBDIQ1(90001,BMCRIEN,1201)_$C(30)
D WRTDXPX
Q
;
WRTDXPX ; WRITE DX's and PX's
D WRTDX
Q:$D(APCHSQIT)
D WRTPX
Q
;
WRTDX ; WRITE DX'S FOR THIS REFERRAL
I '$O(^BMCDX("AD",BMCRIEN,0)) D WRTCATD Q ; no dx's so write category
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="DIAGNOSES"_$C(30)
;X APCHSCKP Q:$D(APCHSQIT)
S BMCPFS="F"
D WRTDXLP ; write finals
I BMCRSTAT="A"!('BMCPFH) S BMCPFS="P" D WRTDXLP ; write provisionals
Q
;
WRTDXLP ; LOOP THRU DX ENTRIES
S (BMCDIEN,BMCPFH)=0
F S BMCDIEN=$O(^BMCDX("AD",BMCRIEN,BMCDIEN)) Q:'BMCDIEN D WRTDX2 Q:$D(APCHSQIT)
Q
;
WRTDX2 ; WRITE ONE DX
S X=^BMCDX(BMCDIEN,0)
Q:$P(X,U,4)'=BMCPFS
S BSDXTMP=$$FILL^BSDX41(9)_$P(^ICD9($P(X,U),0),U)
S BSDXTMP=BSDXTMP_$$FILL^BSDX41(18-$L(BSDXTMP))_$S($P(X,U,4)="P":"PROV",$P(X,U,4)="F":"FINAL",1:"???")_" "_$S($P(X,U,5)="P":"PRI",$P(X,U,5)="S":"SEC",1:"???")
S X=$P(X,U,6)
I X S:$D(^AUTNPOV(X,0)) X=$P(^AUTNPOV(X,0),U) I 1
E D ENP^XBDIQ1(90001.01,BMCDIEN,".019","BMCX(","E") S:BMCX(".019")]"" X=BMCX(".019")
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$$FILL^BSDX41(26-$L(BSDXTMP))_X_$C(30)
S BSDXTMP=""
S BMCPFH=1
;X APCHSCKP
Q
;
WRTPX ; WRITE PX'S FOR THIS REFERRAL
I '$O(^BMCPX("AD",BMCRIEN,0)) D WRTCATS Q ; no px's so write category
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="PROCEDURES"_$C(30)
;X APCHSCKP Q:$D(APCHSQIT)
S BMCPFS="F"
D WRTPXLP ; write finals
I BMCRSTAT="A"!('BMCPFH) S BMCPFS="P" D WRTPXLP ; write provisionals
Q
;
WRTPXLP ; LOOP THRU PX ENTRIES
S (BMCPIEN,BMCPFH)=0
F S BMCPIEN=$O(^BMCPX("AD",BMCRIEN,BMCPIEN)) Q:'BMCPIEN D WRTPX2 Q:$D(APCHSQIT)
Q
;
WRTPX2 ; WRITE ONE PX
S X=^BMCPX(BMCPIEN,0)
Q:$P(X,U,4)'=BMCPFS
S BSDXTMP=$$FILL^BSDX41(9)_$S($P(X,U)'=1:$P(^ICPT($P(X,U),0),U),1:"???")
S BSDXTMP=BSDXTMP_$$FILL^BSDX41(17-$L(BSDXTMP))_$S($P(X,U,4)="P":"PROV",$P(X,U,4)="F":"FINAL",1:"???")_" "_$S($P(X,U,5)="P":"PRI",$P(X,U,5)="S":"SEC",1:"???")
S X=$P(X,U,6)
I X S:$D(^AUTNPOV(X,0)) X=$P(^AUTNPOV(X,0),U) I 1
E D ENP^XBDIQ1(90001.02,BMCPIEN,".019","BMCX(","E") S:BMCX(".019")]"" X=BMCX(".019")
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$$FILL^BSDX41(26-$L(BSDXTMP))_X_$C(30)
S BSDXTMP=""
S BMCPFH=1
;X APCHSCKP
Q
;
WRTCAT ; WRITE DX/SVC CAT
D WRTCATD
D WRTCATS
Q
;
WRTCATD ; WRITE DX CAT
D ENP^XBDIQ1(90001,BMCRIEN,".12","BMCX(","E") S X=BMCX(".12")
S BSDXTMP="DIAGNOSTIC CATEGORY:"
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$$FILL^BSDX41(24-$L(BSDXTMP))_X_$C(30)
S BSDXTMP=""
;X APCHSCKP Q:$D(APCHSQIT)
Q
;
WRTCATS ; WRITE PX CAT
Q ;Remove from HS per Dr. Griffith 11-23-00
D ENP^XBDIQ1(90001,BMCRIEN,".13","BMCX(","E") S X=BMCX(".13")
S BSDXTMP="CPT SERVICE CATEGORY:"
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$$FILL^BSDX41(24-$L(BSDXTMP))_X_$C(30)
S BSDXTMP=""
;X APCHSCKP Q:$D(APCHSQIT)
Q
BSDX41J ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
+1 ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
+2 ;
MRL ; ******************** MOST RECENT LAB * 9000010.09 *******
+1 IF '$DATA(^AUPNVLAB("AA",APCHSPAT))
DO EKGLAB
GOTO MRLX
+2 ;X APCHSCKP Q:$D(APCHSQIT)
+3 ;X:'APCHSNPG APCHSBRK
+4 ; <SETUP>
+5 ; <PROCESS>
+6 DO LBLD
DO LPRT
+7 DO EKGLAB
+8 ;now display lab refusals
+9 SET APCHST="LAB"
SET APCHSFN=60
DO DISPREF^BSDX41F
+10 KILL APCHST,APCHSFN
+11 ; <CLEANUP>
MRLX KILL APCHSLT,APCHSLR,APCHSLTX,APCHSLRT,APCHSLL,APCHSLW,APCHSNMX,APCHSDFN,APCHSIVD,APCHSLTD,APCHSN,Y
+1 KILL ^TMP($JOB,"APCHS"),^TMP($JOB,"APCHS1")
+2 QUIT
+3 ; <BUILD>
LBLD KILL ^TMP($JOB,"APCHS","LAB"),^TMP($JOB,"APCHS1")
+1 SET APCHSLRT=""
FOR APCHSQ=0:0
SET APCHSLRT=$ORDER(^AUPNVLAB("AA",APCHSPAT,APCHSLRT))
IF APCHSLRT=""
QUIT
DO LDATE
+2 DO REORDER
+3 QUIT
REORDER ;reorder by accession, parent and child
+1 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"APCHS","LAB",X))
IF X'=+X
QUIT
Begin DoDot:1
+2 SET Y=$PIECE(^TMP($JOB,"APCHS","LAB",X),U,3)
+3 SET %=$EXTRACT($PIECE(^AUPNVLAB(Y,0),U,6),1,2)
IF %=""
SET %="ZZ"
+4 SET %1=$SELECT($PIECE($GET(^AUPNVLAB(Y,12)),U,8)]"":$PIECE(^AUPNVLAB(Y,12),U,8),1:Y)
+5 SET %2=$SELECT($PIECE($GET(^AUPNVLAB(Y,12)),U,8)="":0,1:Y)
+6 SET ^TMP($JOB,"APCHS1",%,%1,%2,X)=^TMP($JOB,"APCHS","LAB",X)
+7 QUIT
End DoDot:1
+8 KILL ^TMP($JOB,"APCHS")
+9 QUIT
LDATE SET APCHSIVD=$ORDER(^AUPNVLAB("AA",APCHSPAT,APCHSLRT,0))
+1 SET APCHSDFN=0
FOR
SET APCHSDFN=$ORDER(^AUPNVLAB("AA",APCHSPAT,APCHSLRT,APCHSIVD,APCHSDFN))
IF APCHSDFN'=+APCHSDFN
QUIT
IF APCHSIVD&(APCHSIVD'>APCHSDLM)
DO LSET
+2 QUIT
LSET ;
+1 SET APCHSN=^AUPNVLAB(APCHSDFN,0)
SET APCHSLR=$PIECE(APCHSN,U,4)
+2 ;do not display tests that are resulted, result is null and flag says don't display
IF $PIECE($GET(^AUPNVLAB(APCHSDFN,11)),U,9)="R"
IF APCHSLR=""
IF $$VALI^XBDIQ1(60,$PIECE(APCHSN,U),999999901)
QUIT
+3 IF APCHSLR]""
IF APCHSLR'=" "
IF $PIECE(APCHSN,U,5)]""
SET APCHSLR=APCHSLR_" ("_$PIECE(APCHSN,U,5)_")"
+4 IF APCHSLR=""
IF $PIECE($GET(^TMP($JOB,"APCHS","LAB",APCHSLRT)),U,2)]""
QUIT
+5 SET ^TMP($JOB,"APCHS","LAB",APCHSLRT)=(-APCHSIVD\1+9999999)_U_APCHSLR_U_APCHSDFN
SET APCHSLTX=$PIECE(^LAB(60,APCHSLRT,0),U,1)
+6 QUIT
+7 ; <PRINT>
LPRT ;
+1 SET BSDXTMP=" "_"TEST"
+2 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(22-$LENGTH(BSDXTMP))_"RESULT DT/TIME"
+3 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(38-$LENGTH(BSDXTMP))_"VISIT"
+4 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(46-$LENGTH(BSDXTMP))_"RESULT"
+5 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(59-$LENGTH(BSDXTMP))_"UNITS"
+6 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(69-$LENGTH(BSDXTMP))_"REF RANGE"
+7 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
+8 SET BSDXTMP=""
+9 SET APCHSACC=""
FOR
SET APCHSACC=$ORDER(^TMP($JOB,"APCHS1",APCHSACC))
IF APCHSACC=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+10 SET APCHSPAR=0
FOR
SET APCHSPAR=$ORDER(^TMP($JOB,"APCHS1",APCHSACC,APCHSPAR))
IF APCHSPAR'=+APCHSPAR!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+11 SET APCHCHIL=""
FOR
SET APCHCHIL=$ORDER(^TMP($JOB,"APCHS1",APCHSACC,APCHSPAR,APCHCHIL))
IF APCHCHIL=""
QUIT
Begin DoDot:3
+12 SET APCHSLT=$ORDER(^TMP($JOB,"APCHS1",APCHSACC,APCHSPAR,APCHCHIL,0))
+13 SET APCHSDFN=$PIECE(^TMP($JOB,"APCHS1",APCHSACC,APCHSPAR,APCHCHIL,APCHSLT),U,3)
+14 SET Y=$PIECE(^TMP($JOB,"APCHS1",APCHSACC,APCHSPAR,APCHCHIL,APCHSLT),U,1)
SET APCHSLR=$PIECE(^TMP($JOB,"APCHS1",APCHSACC,APCHSPAR,APCHCHIL,APCHSLT),U,2)
XECUTE APCHSCVD
SET APCHSLTD=Y
+15 DO LPRT2
End DoDot:3
End DoDot:2
End DoDot:1
+16 KILL APCHCHIL,APCHSPAR,APCHSACC,APCHSLT
+17 QUIT
LPRT2 ;
+1 SET APCHSLTX=$PIECE(^LAB(60,APCHSLT,0),U)
+2 SET APCHSRDT=$PIECE($GET(^AUPNVLAB(APCHSDFN,12)),U,12)
IF APCHSRDT]""
SET APCHSRDT=$$DATE^APCHSMU($PIECE(APCHSRDT,"."))_"@"_$PIECE($PIECE($$FMTE^XLFDT(APCHSRDT),"@",2),":",1,2)
+3 ;X APCHSCKP Q:$D(APCHSQIT)
+4 IF APCHSNPG
Begin DoDot:1
+5 SET BSDXTMP=" "_"TEST"
+6 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(22-$LENGTH(BSDXTMP))_"RESULT DT/TIME"
+7 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(38-$LENGTH(BSDXTMP))_"VISIT"
+8 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(46-$LENGTH(BSDXTMP))_"RESULT"
+9 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(59-$LENGTH(BSDXTMP))_"UNITS"
+10 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(69-$LENGTH(BSDXTMP))_"REF RANGE"
+11 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
End DoDot:1
+12 SET BSDXTMP=""
+13 IF APCHCHIL
SET BSDXTMP=" "
+14 SET BSDXTMP=BSDXTMP_$EXTRACT(APCHSLTX,1,20)
+15 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(22-$LENGTH(BSDXTMP))_APCHSRDT
+16 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(37-$LENGTH(BSDXTMP))_APCHSLTD
+17 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(46-$LENGTH(BSDXTMP))_APCHSLR
+18 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(59-$LENGTH(BSDXTMP))_$PIECE($GET(^AUPNVLAB(APCHSDFN,11)),U)
+19 IF $PIECE($GET(^AUPNVLAB(APCHSDFN,11)),U,4)]""!($PIECE($GET(^AUPNVLAB(APCHSDFN,11)),U,5)]"")
SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(69-$LENGTH(BSDXTMP))_$PIECE(^AUPNVLAB(APCHSDFN,11),U,4)_"-"_$PIECE(^AUPNVLAB(APCHSDFN,11),U,5)
+20 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
+21 IF '$PIECE(^APCHSCTL(APCHSTYP,0),U,7)
QUIT
+22 ;print out comments per Dorothy
+23 SET APCHSX=0
FOR
SET APCHSX=$ORDER(^AUPNVLAB(APCHSDFN,21,APCHSX))
IF APCHSX'=+APCHSX!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+24 ;X APCHSCKP Q:$D(APCHSQIT)
+25 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=^AUPNVLAB(APCHSDFN,21,APCHSX,0)_$CHAR(30)
End DoDot:1
+26 FOR APCHSX=1:1:3
IF $DATA(APCHSQIT)
QUIT
IF $PIECE($GET(^AUPNVLAB(APCHSDFN,13)),U,APCHSX)]""
Begin DoDot:1
+27 ;X APCHSCKP Q:$D(APCHSQIT)
+28 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$PIECE(^AUPNVLAB(APCHSDFN,13),U,APCHSX)_$CHAR(30)
End DoDot:1
+29 QUIT
+30 ;
EKGLAB ;ENTRY POINT - EKG display in most recent lab panel
+1 IF '$DATA(^AUPNVDXP("AC",APCHSPAT))
QUIT
+2 KILL APCHS
+3 SET APCHSERR=$$START1^APCLDF(APCHSPAT_"^LAST DIAGNOSTIC ECG SUMMARY","APCHS(")
+4 IF APCHSERR
GOTO EKGLABX
+5 ; *array APCHS(1)="DATE^RESULT^DIAG PROC^VDIAG PROCEDURE IEN^AUPNVDXP^VISIT IEN"
+6 KILL APCHSERR
+7 SET APCHSIVD=$SELECT($DATA(APCHS(1)):9999999-$PIECE($PIECE(APCHS(1),U,1),".",1),1:"")
+8 IF 'APCHSIVD!(APCHSIVD>APCHSDLM)
QUIT
+9 SET (APCHSLTX,APCHSLT)="EKG"
+10 SET APCHSLRT("EKG")=$PIECE(APCHS(1),U,1)_"^"_$PIECE(APCHS(1),U,2)
+11 ; computes/prints ekg info
DO EKGPRT
EKGLABX ;
+1 KILL APCHSERR,APCHS(1)
+2 QUIT
+3 ;
EKGPRT ;computers/prints ekg info
+1 SET Y=$PIECE(APCHSLRT(APCHSLT),U,1)
XECUTE APCHSCVD
SET APCHSLTD=Y
+2 SET APCHSLR=$PIECE(APCHSLRT(APCHSLT),U,2)
+3 ;IHS/CMI/LAB added borderline
SET APCHSLR=$SELECT(APCHSLR="N":"NORMAL",APCHSLR="A":"ABNORMAL",APCHSLR="B":"BORDERLINE",1:"<none recorded>")
+4 SET APCHSLW=$SELECT($GET(APCHSLW):APCHSLW,1:28)
+5 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+6 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=APCHSLTX_$$FILL^BSDX41(APCHSLW-$LENGTH(APCHSLTX))_APCHSLTD_" "_APCHSLR_$CHAR(30)
+7 QUIT
+8 ;
MCIS ; *********** MANAGED CARE MIS * 90001
+1 ;X APCHSCKP Q:$D(APCHSQIT)
+2 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+3 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+4 NEW X
+5 ; write mcis summary
SET X="BMCHS"
XECUTE ^%ZOSF("TEST")
IF $TEST
GOTO HS
+6 ; exit if no referrals for patient
IF '$DATA(^BMCREF("D",APCHSPAT))
GOTO MCISX
+7 ;X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
+8 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)="<MCIS DISPLAY ROUTINE MISSING!>"_$CHAR(30)
MCISX ;MCIS EXIT
+1 ;
HS ;EP-called from health summary
+1 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$$CTR^BMC(" <<< RCIS ACTIVE REFERRALS >>> ",80)_$CHAR(30)
+2 IF '$DATA(^BMCREF("AA",APCHSPAT))
Begin DoDot:1
+3 ;X APCHSCKP Q:$D(APCHSQIT)
+4 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+5 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)="No Referred Care Referral records on file."_$CHAR(30)
+6 QUIT
End DoDot:1
QUIT
+7 ; date one year ago
SET X1=DT
SET X2=-365
DO C^%DTC
SET BMCYAGO=X
+8 IF $ORDER(^BMCREF("AA",APCHSPAT,""),-1)<BMCYAGO
Begin DoDot:1
+9 ;X APCHSCKP Q:$D(APCHSQIT)
+10 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+11 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)="No Referred Care Referral records within last year."_$CHAR(30)
+12 QUIT
End DoDot:1
QUIT
+13 SET BMCRDATE=""
+14 FOR
SET BMCRDATE=$ORDER(^BMCREF("AA",APCHSPAT,BMCRDATE),-1)
IF BMCRDATE<BMCYAGO!($DATA(APCHSQIT))
QUIT
SET BMCRIEN=0
FOR
SET BMCRIEN=$ORDER(^BMCREF("AA",APCHSPAT,BMCRDATE,BMCRIEN))
IF 'BMCRIEN!($DATA(APCHSQIT))
QUIT
DO WRTREF
XIT ;
+1 KILL DIEN,BMCPFH,BMCPFS,BMCPIEN,BMCYAGO,BMCCHSCT,BMCDFN,BMCRDATE,BMCREC,BMCRIEN,BMCRIO,BMCRNUMB,BMCRREC,BMCRSTAT,BMCRTYPE,BMCX,BMCDIEN
+2 QUIT
+3 ;
WRTREF ; WRITE RCIS REFERRAL ENTRY
+1 SET BMCRREC=^BMCREF(BMCRIEN,0)
+2 SET Y=BMCRIEN
+3 DO ^BMCREF
+4 ;
+5 ;Quit if Not an Active Referral
IF BMCRSTAT'="A"
QUIT
+6 ;
+7 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+8 SET BSDXTMP="BEGIN DOS: "_$$AVDOS^BMCRLU(BMCRIEN,"C")_" "_$$AVDOS^BMCRLU(BMCRIEN,"E")
+9 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(36-$LENGTH(BSDXTMP))_"DISCHARGE CONSULT DT: "_$$FMTE^XLFDT($PIECE(BMCRREC,U,18),"5D")
+10 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
+11 SET BSDXTMP=""
+12 SET BSDXTMP="DATE REFERRED: "_$$FMTE^XLFDT($PIECE(BMCRREC,U),"5D")
+13 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$$FILL^BSDX41(36-$LENGTH(BSDXTMP))_"CHS STATUS: "_$$VAL^XBDIQ1(90001,BMCRIEN,1112)_$CHAR(30)
+14 SET BSDXTMP=""
+15 SET BMCMCC=""
+16 IF $DATA(^BMCPARM(DUZ(2),4100))
SET BMCMCC=$PIECE($GET(^BMCPARM(DUZ(2),4100)),U)
+17 IF BMCMCC="Y"
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$$FILL^BSDX41(36)_"MCC ACTION: "_$$VAL^XBDIQ1(90001,BMCRIEN,1123)_$CHAR(30)
+18 SET BSDXTMP="REFERRED BY: "_$SELECT($PIECE(BMCRREC,U,6):$EXTRACT($PIECE(^VA(200,$PIECE(BMCRREC,U,6),0),U),1,22),1:"???")
+19 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$$FILL^BSDX41(36-$LENGTH(BSDXTMP))_"REFERRED TO: "_$$TOFAC^BMC(BMCRIEN)_$CHAR(30)
+20 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)="PURPOSE: "_$$VAL^XBDIQ1(90001,BMCRIEN,1201)_$CHAR(30)
+21 DO WRTDXPX
+22 QUIT
+23 ;
WRTDXPX ; WRITE DX's and PX's
+1 DO WRTDX
+2 IF $DATA(APCHSQIT)
QUIT
+3 DO WRTPX
+4 QUIT
+5 ;
WRTDX ; WRITE DX'S FOR THIS REFERRAL
+1 ; no dx's so write category
IF '$ORDER(^BMCDX("AD",BMCRIEN,0))
DO WRTCATD
QUIT
+2 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)="DIAGNOSES"_$CHAR(30)
+3 ;X APCHSCKP Q:$D(APCHSQIT)
+4 SET BMCPFS="F"
+5 ; write finals
DO WRTDXLP
+6 ; write provisionals
IF BMCRSTAT="A"!('BMCPFH)
SET BMCPFS="P"
DO WRTDXLP
+7 QUIT
+8 ;
WRTDXLP ; LOOP THRU DX ENTRIES
+1 SET (BMCDIEN,BMCPFH)=0
+2 FOR
SET BMCDIEN=$ORDER(^BMCDX("AD",BMCRIEN,BMCDIEN))
IF 'BMCDIEN
QUIT
DO WRTDX2
IF $DATA(APCHSQIT)
QUIT
+3 QUIT
+4 ;
WRTDX2 ; WRITE ONE DX
+1 SET X=^BMCDX(BMCDIEN,0)
+2 IF $PIECE(X,U,4)'=BMCPFS
QUIT
+3 SET BSDXTMP=$$FILL^BSDX41(9)_$PIECE(^ICD9($PIECE(X,U),0),U)
+4 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(18-$LENGTH(BSDXTMP))_$SELECT($PIECE(X,U,4)="P":"PROV",$PIECE(X,U,4)="F":"FINAL",1:"???")_" "_$SELECT($PIECE(X,U,5)="P":"PRI",$PIECE(X,U,5)="S":"SEC",1:"???")
+5 SET X=$PIECE(X,U,6)
+6 IF X
IF $DATA(^AUTNPOV(X,0))
SET X=$PIECE(^AUTNPOV(X,0),U)
IF 1
+7 IF '$TEST
DO ENP^XBDIQ1(90001.01,BMCDIEN,".019","BMCX(","E")
IF BMCX(".019")]""
SET X=BMCX(".019")
+8 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$$FILL^BSDX41(26-$LENGTH(BSDXTMP))_X_$CHAR(30)
+9 SET BSDXTMP=""
+10 SET BMCPFH=1
+11 ;X APCHSCKP
+12 QUIT
+13 ;
WRTPX ; WRITE PX'S FOR THIS REFERRAL
+1 ; no px's so write category
IF '$ORDER(^BMCPX("AD",BMCRIEN,0))
DO WRTCATS
QUIT
+2 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)="PROCEDURES"_$CHAR(30)
+3 ;X APCHSCKP Q:$D(APCHSQIT)
+4 SET BMCPFS="F"
+5 ; write finals
DO WRTPXLP
+6 ; write provisionals
IF BMCRSTAT="A"!('BMCPFH)
SET BMCPFS="P"
DO WRTPXLP
+7 QUIT
+8 ;
WRTPXLP ; LOOP THRU PX ENTRIES
+1 SET (BMCPIEN,BMCPFH)=0
+2 FOR
SET BMCPIEN=$ORDER(^BMCPX("AD",BMCRIEN,BMCPIEN))
IF 'BMCPIEN
QUIT
DO WRTPX2
IF $DATA(APCHSQIT)
QUIT
+3 QUIT
+4 ;
WRTPX2 ; WRITE ONE PX
+1 SET X=^BMCPX(BMCPIEN,0)
+2 IF $PIECE(X,U,4)'=BMCPFS
QUIT
+3 SET BSDXTMP=$$FILL^BSDX41(9)_$SELECT($PIECE(X,U)'=1:$PIECE(^ICPT($PIECE(X,U),0),U),1:"???")
+4 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(17-$LENGTH(BSDXTMP))_$SELECT($PIECE(X,U,4)="P":"PROV",$PIECE(X,U,4)="F":"FINAL",1:"???")_" "_$SELECT($PIECE(X,U,5)="P":"PRI",$PIECE(X,U,5)="S":"SEC",1:"???")
+5 SET X=$PIECE(X,U,6)
+6 IF X
IF $DATA(^AUTNPOV(X,0))
SET X=$PIECE(^AUTNPOV(X,0),U)
IF 1
+7 IF '$TEST
DO ENP^XBDIQ1(90001.02,BMCPIEN,".019","BMCX(","E")
IF BMCX(".019")]""
SET X=BMCX(".019")
+8 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$$FILL^BSDX41(26-$LENGTH(BSDXTMP))_X_$CHAR(30)
+9 SET BSDXTMP=""
+10 SET BMCPFH=1
+11 ;X APCHSCKP
+12 QUIT
+13 ;
WRTCAT ; WRITE DX/SVC CAT
+1 DO WRTCATD
+2 DO WRTCATS
+3 QUIT
+4 ;
WRTCATD ; WRITE DX CAT
+1 DO ENP^XBDIQ1(90001,BMCRIEN,".12","BMCX(","E")
SET X=BMCX(".12")
+2 SET BSDXTMP="DIAGNOSTIC CATEGORY:"
+3 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$$FILL^BSDX41(24-$LENGTH(BSDXTMP))_X_$CHAR(30)
+4 SET BSDXTMP=""
+5 ;X APCHSCKP Q:$D(APCHSQIT)
+6 QUIT
+7 ;
WRTCATS ; WRITE PX CAT
+1 ;Remove from HS per Dr. Griffith 11-23-00
QUIT
+2 DO ENP^XBDIQ1(90001,BMCRIEN,".13","BMCX(","E")
SET X=BMCX(".13")
+3 SET BSDXTMP="CPT SERVICE CATEGORY:"
+4 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$$FILL^BSDX41(24-$LENGTH(BSDXTMP))_X_$CHAR(30)
+5 SET BSDXTMP=""
+6 ;X APCHSCKP Q:$D(APCHSQIT)
+7 QUIT
