- 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