BMCHS ; IHS/PHXAO/TMJ - RCIS HEALTH SUMMARY COMPONENT ;
;;4.0;REFERRED CARE INFO SYSTEM;**3,9**;JAN 09, 2006;Build 101
;4.0*3 10.25.2007 IHS/OIT/FCJ ADDED CSV CHANGES
;4.0*9 04.14.2014 IHS.OIT.FCJ ICD-10 CHANGES
; This routine generates the RCIS component of the Health Summary.
;
HS ;EP-called from health summary
;D:$G(BMCPARM)="" PARMSET^BMC
W $$CTR^BMC(" <<< RCIS ACTIVE REFERRALS >>> ",80),!
I '$D(^BMCREF("AA",APCHSPAT)) X APCHSCKP Q:$D(APCHSQIT) W !,"No Referred Care Referral records on file.",! Q
S X1=DT,X2=-365 D C^%DTC S BMCYAGO=X ; date one year ago
I $O(^BMCREF("AA",APCHSPAT,""),-1)<BMCYAGO X APCHSCKP Q:$D(APCHSQIT) W !,"No Referred Care Referral records within last year.",! 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
N BMCRDATE ;PREVENT HS FR GETTING CAUGHT IN INF LOOP ;FCJ 3.30.05
S BMCRREC=^BMCREF(BMCRIEN,0)
S Y=BMCRIEN
D ^BMCREF
;
Q:BMCRSTAT'="A" ;Quit if Not an Active Referral
;
W !,"BEGIN DOS: ",$$AVDOS^BMCRLU(BMCRIEN,"C")," ",$$AVDOS^BMCRLU(BMCRIEN,"E")
W ?37,"DISCHARGE CONSULT DT: ",$$FMTE^XLFDT($P(BMCRREC,U,18),"5D")
W !,"DATE REFERRED: ",$$FMTE^XLFDT($P(BMCRREC,U),"5D")
W ?37,"CHS STATUS: ",$$VAL^XBDIQ1(90001,BMCRIEN,1112)
S BMCMCC=""
I $D(^BMCPARM(DUZ(2),4100)) S BMCMCC=$P($G(^BMCPARM(DUZ(2),4100)),U)
I BMCMCC="Y" W !?37,"MCC ACTION: ",$$VAL^XBDIQ1(90001,BMCRIEN,1123)
W !,"REFERRED BY: ",$S($P(BMCRREC,U,6):$E($P(^VA(200,$P(BMCRREC,U,6),0),U),1,22),1:"???"),?37,"REFERRED TO: ",$$TOFAC^BMC(BMCRIEN)
W !,"PURPOSE: "_$$VAL^XBDIQ1(90001,BMCRIEN,1201)
W !
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
W "DIAGNOSES",!
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
;4.0*3 10.25.2007 IHS/OIT/FCJ ADDED CSV CHANGES;4.0*9 ICD-10 CHANGES
;W ?10,$P(^ICD9($P(X,U),0),U,2),?18,$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:"???")
W ?10,$P($$ICDDX^ICDCODE($P(X,U),,,"I"),U,2),?18,$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")
W ?27,X
W !
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
W "PROCEDURES",!
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
;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES
;W ?10,$S($P(X,U)'=1:$P(^ICPT($P(X,U),0),U),1:"???"),?18,$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:"???")
W ?10,$S($P(X,U)'=1:$P($$CPT^ICPTCOD($P(X,U),0),U,2),1:"???"),?18,$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")
W ?27,X
W !
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")
W "DIAGNOSTIC CATEGORY:",?25,X,!
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")
W "CPT SERVICE CATEGORY:",?25,X,!
X APCHSCKP Q:$D(APCHSQIT)
Q
BMCHS ; IHS/PHXAO/TMJ - RCIS HEALTH SUMMARY COMPONENT ;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**3,9**;JAN 09, 2006;Build 101
+2 ;4.0*3 10.25.2007 IHS/OIT/FCJ ADDED CSV CHANGES
+3 ;4.0*9 04.14.2014 IHS.OIT.FCJ ICD-10 CHANGES
+4 ; This routine generates the RCIS component of the Health Summary.
+5 ;
HS ;EP-called from health summary
+1 ;D:$G(BMCPARM)="" PARMSET^BMC
+2 WRITE $$CTR^BMC(" <<< RCIS ACTIVE REFERRALS >>> ",80),!
+3 IF '$DATA(^BMCREF("AA",APCHSPAT))
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE !,"No Referred Care Referral records on file.",!
QUIT
+4 ; date one year ago
SET X1=DT
SET X2=-365
DO C^%DTC
SET BMCYAGO=X
+5 IF $ORDER(^BMCREF("AA",APCHSPAT,""),-1)<BMCYAGO
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE !,"No Referred Care Referral records within last year.",!
QUIT
+6 SET BMCRDATE=""
+7 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 ;PREVENT HS FR GETTING CAUGHT IN INF LOOP ;FCJ 3.30.05
NEW BMCRDATE
+2 SET BMCRREC=^BMCREF(BMCRIEN,0)
+3 SET Y=BMCRIEN
+4 DO ^BMCREF
+5 ;
+6 ;Quit if Not an Active Referral
IF BMCRSTAT'="A"
QUIT
+7 ;
+8 WRITE !,"BEGIN DOS: ",$$AVDOS^BMCRLU(BMCRIEN,"C")," ",$$AVDOS^BMCRLU(BMCRIEN,"E")
+9 WRITE ?37,"DISCHARGE CONSULT DT: ",$$FMTE^XLFDT($PIECE(BMCRREC,U,18),"5D")
+10 WRITE !,"DATE REFERRED: ",$$FMTE^XLFDT($PIECE(BMCRREC,U),"5D")
+11 WRITE ?37,"CHS STATUS: ",$$VAL^XBDIQ1(90001,BMCRIEN,1112)
+12 SET BMCMCC=""
+13 IF $DATA(^BMCPARM(DUZ(2),4100))
SET BMCMCC=$PIECE($GET(^BMCPARM(DUZ(2),4100)),U)
+14 IF BMCMCC="Y"
WRITE !?37,"MCC ACTION: ",$$VAL^XBDIQ1(90001,BMCRIEN,1123)
+15 WRITE !,"REFERRED BY: ",$SELECT($PIECE(BMCRREC,U,6):$EXTRACT($PIECE(^VA(200,$PIECE(BMCRREC,U,6),0),U),1,22),1:"???"),?37,"REFERRED TO: ",$$TOFAC^BMC(BMCRIEN)
+16 WRITE !,"PURPOSE: "_$$VAL^XBDIQ1(90001,BMCRIEN,1201)
+17 WRITE !
+18 DO WRTDXPX
+19 QUIT
+20 ;
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 WRITE "DIAGNOSES",!
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+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 ;4.0*3 10.25.2007 IHS/OIT/FCJ ADDED CSV CHANGES;4.0*9 ICD-10 CHANGES
+4 ;W ?10,$P(^ICD9($P(X,U),0),U,2),?18,$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:"???")
+5 WRITE ?10,$PIECE($$ICDDX^ICDCODE($PIECE(X,U),,,"I"),U,2),?18,$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:"???")
+6 SET X=$PIECE(X,U,6)
+7 IF X
IF $DATA(^AUTNPOV(X,0))
SET X=$PIECE(^AUTNPOV(X,0),U)
IF 1
+8 IF '$TEST
DO ENP^XBDIQ1(90001.01,BMCDIEN,".019","BMCX(","E")
IF BMCX(".019")]""
SET X=BMCX(".019")
+9 WRITE ?27,X
+10 WRITE !
+11 SET BMCPFH=1
+12 XECUTE APCHSCKP
+13 QUIT
+14 ;
WRTPX ; WRITE PX'S FOR THIS REFERRAL
+1 ; no px's so write category
IF '$ORDER(^BMCPX("AD",BMCRIEN,0))
DO WRTCATS
QUIT
+2 WRITE "PROCEDURES",!
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+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 ;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES
+4 ;W ?10,$S($P(X,U)'=1:$P(^ICPT($P(X,U),0),U),1:"???"),?18,$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:"???")
+5 WRITE ?10,$SELECT($PIECE(X,U)'=1:$PIECE($$CPT^ICPTCOD($PIECE(X,U),0),U,2),1:"???"),?18,$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:"???")
+6 SET X=$PIECE(X,U,6)
+7 IF X
IF $DATA(^AUTNPOV(X,0))
SET X=$PIECE(^AUTNPOV(X,0),U)
IF 1
+8 IF '$TEST
DO ENP^XBDIQ1(90001.02,BMCPIEN,".019","BMCX(","E")
IF BMCX(".019")]""
SET X=BMCX(".019")
+9 WRITE ?27,X
+10 WRITE !
+11 SET BMCPFH=1
+12 XECUTE APCHSCKP
+13 QUIT
+14 ;
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 WRITE "DIAGNOSTIC CATEGORY:",?25,X,!
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+4 QUIT
+5 ;
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 WRITE "CPT SERVICE CATEGORY:",?25,X,!
+4 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+5 QUIT
