BHSRCIS ;IHS/CIA/MGH - Health Summary for Referred care ;22-Apr-2014 09:36;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**9**;Jan 06, 2006;Build 16
;===================================================================
;Taken from BMCHS
; IHS/PHXAO/TMJ - RCIS HEALTH SUMMARY COMPONENT ;
;;2.0T1;REFERRED CARE INFO SYSTEM;;NOV 21, 2001
;;Health summary routine to get data from REFERRED CARE INFO SYSTEM;;NOV 21, 2001
;
; This routine generates the RCIS component of the Health Summary.
;
HS ;EP-called from health summary
N X,X1,X2,Y
D CKP^GMTSUP Q:$D(GMTSQIT)
W $$CTR^BMC(" <<< RCIS ACTIVE REFERRALS >>> ",80),!
I '$D(^BMCREF("AA",BHSPAT)) D CKP^GMTSUP Q:$D(GMTSQIT) 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",BHSPAT,""),-1)<BMCYAGO D CKP^GMTSUP Q:$D(GMTSQIT) W !,"No Referred Care Referral records within last year.",! Q
S BMCRDATE=""
F S BMCRDATE=$O(^BMCREF("AA",BHSPAT,BMCRDATE),-1) Q:BMCRDATE<BMCYAGO!($D(GMTSQIT)) D
.S BMCRIEN=0 F S BMCRIEN=$O(^BMCREF("AA",BHSPAT,BMCRDATE,BMCRIEN)) Q:'BMCRIEN!($D(GMTSQIT)) D WRTREF
XIT ;
K DIEN,BMCPFH,BMCPFS,BMCPIEN,BMCYAGO,BMCMCC,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
;
D CKP^GMTSUP Q:$D(GMTSQIT)
W !,"BEGIN DOS: ",$$AVDOS^BMCRLU(BMCRIEN,"C")," ",$$AVDOS^BMCRLU(BMCRIEN,"E"),?37,"DISCHARGE CONSULT DT: ",$$FMTE^XLFDT($P(BMCRREC,U,18),"5D") W !,"DATE REFERRED: ",$$FMTE^XLFDT($P(BMCRREC,U),"5D") ;Y2000
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)
D CKP^GMTSUP Q:$D(GMTSQIT)
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)
D CKP^GMTSUP Q:$D(GMTSQIT)
W !,"PURPOSE: "_$$VAL^XBDIQ1(90001,BMCRIEN,1201)
W !
D WRTDXPX
Q
;
WRTDXPX ; WRITE DX's and PX's
D WRTDX
Q:$D(GMTSQIT)
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",!
D CKP^GMTSUP Q:$D(GMTSQIT)
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(GMTSQIT)
Q
;
WRTDX2 ; WRITE ONE DX
S X=^BMCDX(BMCDIEN,0)
Q:$P(X,U,4)'=BMCPFS
;Patch 9
I $$AICD^BHSUTL D
.W ?10,$P($$ICDDX^ICDEX($P(X,U),0,"","I"),U),?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:"???")
E D
.W ?10,$P($$ICDDX^ICDCODE($P(X,U),0),U),?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(^ICD9($P(X,U),0),U),?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
D CKP^GMTSUP
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",!
D CKP^GMTSUP Q:$D(GMTSQIT)
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(GMTSQIT)
Q
;
WRTPX2 ; WRITE ONE PX
S X=^BMCPX(BMCPIEN,0)
Q:$P(X,U,4)'=BMCPFS
;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
D CKP^GMTSUP
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,!
D CKP^GMTSUP Q:$D(GMTSQIT)
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,!
D CKP^GMTSUP Q:$D(GMTSQIT)
Q
BHSRCIS ;IHS/CIA/MGH - Health Summary for Referred care ;22-Apr-2014 09:36;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**9**;Jan 06, 2006;Build 16
+2 ;===================================================================
+3 ;Taken from BMCHS
+4 ; IHS/PHXAO/TMJ - RCIS HEALTH SUMMARY COMPONENT ;
+5 ;;2.0T1;REFERRED CARE INFO SYSTEM;;NOV 21, 2001
+6 ;;Health summary routine to get data from REFERRED CARE INFO SYSTEM;;NOV 21, 2001
+7 ;
+8 ; This routine generates the RCIS component of the Health Summary.
+9 ;
HS ;EP-called from health summary
+1 NEW X,X1,X2,Y
+2 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+3 WRITE $$CTR^BMC(" <<< RCIS ACTIVE REFERRALS >>> ",80),!
+4 IF '$DATA(^BMCREF("AA",BHSPAT))
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE !,"No Referred Care Referral records on file.",!
QUIT
+5 ; date one year ago
SET X1=DT
SET X2=-365
DO C^%DTC
SET BMCYAGO=X
+6 IF $ORDER(^BMCREF("AA",BHSPAT,""),-1)<BMCYAGO
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE !,"No Referred Care Referral records within last year.",!
QUIT
+7 SET BMCRDATE=""
+8 FOR
SET BMCRDATE=$ORDER(^BMCREF("AA",BHSPAT,BMCRDATE),-1)
IF BMCRDATE<BMCYAGO!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+9 SET BMCRIEN=0
FOR
SET BMCRIEN=$ORDER(^BMCREF("AA",BHSPAT,BMCRDATE,BMCRIEN))
IF 'BMCRIEN!($DATA(GMTSQIT))
QUIT
DO WRTREF
End DoDot:1
XIT ;
+1 KILL DIEN,BMCPFH,BMCPFS,BMCPIEN,BMCYAGO,BMCMCC,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 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+8 ;Y2000
WRITE !,"BEGIN DOS: ",$$AVDOS^BMCRLU(BMCRIEN,"C")," ",$$AVDOS^BMCRLU(BMCRIEN,"E"),?37,"DISCHARGE CONSULT DT: ",$$FMTE^XLFDT($PIECE(BMCRREC,U,18),"5D")
WRITE !,"DATE REFERRED: ",$$FMTE^XLFDT($PIECE(BMCRREC,U),"5D")
+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 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+16 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)
+17 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+18 WRITE !,"PURPOSE: "_$$VAL^XBDIQ1(90001,BMCRIEN,1201)
+19 WRITE !
+20 DO WRTDXPX
+21 QUIT
+22 ;
WRTDXPX ; WRITE DX's and PX's
+1 DO WRTDX
+2 IF $DATA(GMTSQIT)
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 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
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(GMTSQIT)
QUIT
+3 QUIT
+4 ;
WRTDX2 ; WRITE ONE DX
+1 SET X=^BMCDX(BMCDIEN,0)
+2 IF $PIECE(X,U,4)'=BMCPFS
QUIT
+3 ;Patch 9
+4 IF $$AICD^BHSUTL
Begin DoDot:1
+5 WRITE ?10,$PIECE($$ICDDX^ICDEX($PIECE(X,U),0,"","I"),U),?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:"???")
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 WRITE ?10,$PIECE($$ICDDX^ICDCODE($PIECE(X,U),0),U),?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:"???")
End DoDot:1
+8 ;W ?10,$P(^ICD9($P(X,U),0),U),?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:"???")
+9 SET X=$PIECE(X,U,6)
+10 IF X
IF $DATA(^AUTNPOV(X,0))
SET X=$PIECE(^AUTNPOV(X,0),U)
IF 1
+11 IF '$TEST
DO ENP^XBDIQ1(90001.01,BMCDIEN,".019","BMCX(","E")
IF BMCX(".019")]""
SET X=BMCX(".019")
+12 WRITE ?27,X
+13 WRITE !
+14 SET BMCPFH=1
+15 DO CKP^GMTSUP
+16 QUIT
+17 ;
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 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
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(GMTSQIT)
QUIT
+3 QUIT
+4 ;
WRTPX2 ; WRITE ONE PX
+1 SET X=^BMCPX(BMCPIEN,0)
+2 IF $PIECE(X,U,4)'=BMCPFS
QUIT
+3 ;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:"???")
+4 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:"???")
+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 WRITE ?27,X
+9 WRITE !
+10 SET BMCPFH=1
+11 DO CKP^GMTSUP
+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 WRITE "DIAGNOSTIC CATEGORY:",?25,X,!
+3 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
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 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+5 QUIT
