Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BMCHS

BMCHS.m

Go to the documentation of this file.
  1. BMCHS ; IHS/PHXAO/TMJ - RCIS HEALTH SUMMARY COMPONENT ;
  1. ;;4.0;REFERRED CARE INFO SYSTEM;**3,9**;JAN 09, 2006;Build 101
  1. ;4.0*3 10.25.2007 IHS/OIT/FCJ ADDED CSV CHANGES
  1. ;4.0*9 04.14.2014 IHS.OIT.FCJ ICD-10 CHANGES
  1. ; This routine generates the RCIS component of the Health Summary.
  1. ;
  1. HS ;EP-called from health summary
  1. ;D:$G(BMCPARM)="" PARMSET^BMC
  1. W $$CTR^BMC(" <<< RCIS ACTIVE REFERRALS >>> ",80),!
  1. I '$D(^BMCREF("AA",APCHSPAT)) X APCHSCKP Q:$D(APCHSQIT) W !,"No Referred Care Referral records on file.",! Q
  1. S X1=DT,X2=-365 D C^%DTC S BMCYAGO=X ; date one year ago
  1. I $O(^BMCREF("AA",APCHSPAT,""),-1)<BMCYAGO X APCHSCKP Q:$D(APCHSQIT) W !,"No Referred Care Referral records within last year.",! Q
  1. S BMCRDATE=""
  1. 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
  1. XIT ;
  1. K DIEN,BMCPFH,BMCPFS,BMCPIEN,BMCYAGO,BMCCHSCT,BMCDFN,BMCRDATE,BMCREC,BMCRIEN,BMCRIO,BMCRNUMB,BMCRREC,BMCRSTAT,BMCRTYPE,BMCX,BMCDIEN
  1. Q
  1. ;
  1. WRTREF ; WRITE RCIS REFERRAL ENTRY
  1. N BMCRDATE ;PREVENT HS FR GETTING CAUGHT IN INF LOOP ;FCJ 3.30.05
  1. S BMCRREC=^BMCREF(BMCRIEN,0)
  1. S Y=BMCRIEN
  1. D ^BMCREF
  1. ;
  1. Q:BMCRSTAT'="A" ;Quit if Not an Active Referral
  1. ;
  1. W !,"BEGIN DOS: ",$$AVDOS^BMCRLU(BMCRIEN,"C")," ",$$AVDOS^BMCRLU(BMCRIEN,"E")
  1. W ?37,"DISCHARGE CONSULT DT: ",$$FMTE^XLFDT($P(BMCRREC,U,18),"5D")
  1. W !,"DATE REFERRED: ",$$FMTE^XLFDT($P(BMCRREC,U),"5D")
  1. W ?37,"CHS STATUS: ",$$VAL^XBDIQ1(90001,BMCRIEN,1112)
  1. S BMCMCC=""
  1. I $D(^BMCPARM(DUZ(2),4100)) S BMCMCC=$P($G(^BMCPARM(DUZ(2),4100)),U)
  1. I BMCMCC="Y" W !?37,"MCC ACTION: ",$$VAL^XBDIQ1(90001,BMCRIEN,1123)
  1. 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)
  1. W !,"PURPOSE: "_$$VAL^XBDIQ1(90001,BMCRIEN,1201)
  1. W !
  1. D WRTDXPX
  1. Q
  1. ;
  1. WRTDXPX ; WRITE DX's and PX's
  1. D WRTDX
  1. Q:$D(APCHSQIT)
  1. D WRTPX
  1. Q
  1. ;
  1. WRTDX ; WRITE DX'S FOR THIS REFERRAL
  1. I '$O(^BMCDX("AD",BMCRIEN,0)) D WRTCATD Q ; no dx's so write category
  1. W "DIAGNOSES",!
  1. X APCHSCKP Q:$D(APCHSQIT)
  1. S BMCPFS="F"
  1. D WRTDXLP ; write finals
  1. I BMCRSTAT="A"!('BMCPFH) S BMCPFS="P" D WRTDXLP ; write provisionals
  1. Q
  1. ;
  1. WRTDXLP ; LOOP THRU DX ENTRIES
  1. S (BMCDIEN,BMCPFH)=0
  1. F S BMCDIEN=$O(^BMCDX("AD",BMCRIEN,BMCDIEN)) Q:'BMCDIEN D WRTDX2 Q:$D(APCHSQIT)
  1. Q
  1. ;
  1. WRTDX2 ; WRITE ONE DX
  1. S X=^BMCDX(BMCDIEN,0)
  1. Q:$P(X,U,4)'=BMCPFS
  1. ;4.0*3 10.25.2007 IHS/OIT/FCJ ADDED CSV CHANGES;4.0*9 ICD-10 CHANGES
  1. ;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:"???")
  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:"???")
  1. S X=$P(X,U,6)
  1. I X S:$D(^AUTNPOV(X,0)) X=$P(^AUTNPOV(X,0),U) I 1
  1. E D ENP^XBDIQ1(90001.01,BMCDIEN,".019","BMCX(","E") S:BMCX(".019")]"" X=BMCX(".019")
  1. W ?27,X
  1. W !
  1. S BMCPFH=1
  1. X APCHSCKP
  1. Q
  1. ;
  1. WRTPX ; WRITE PX'S FOR THIS REFERRAL
  1. I '$O(^BMCPX("AD",BMCRIEN,0)) D WRTCATS Q ; no px's so write category
  1. W "PROCEDURES",!
  1. X APCHSCKP Q:$D(APCHSQIT)
  1. S BMCPFS="F"
  1. D WRTPXLP ; write finals
  1. I BMCRSTAT="A"!('BMCPFH) S BMCPFS="P" D WRTPXLP ; write provisionals
  1. Q
  1. ;
  1. WRTPXLP ; LOOP THRU PX ENTRIES
  1. S (BMCPIEN,BMCPFH)=0
  1. F S BMCPIEN=$O(^BMCPX("AD",BMCRIEN,BMCPIEN)) Q:'BMCPIEN D WRTPX2 Q:$D(APCHSQIT)
  1. Q
  1. ;
  1. WRTPX2 ; WRITE ONE PX
  1. S X=^BMCPX(BMCPIEN,0)
  1. Q:$P(X,U,4)'=BMCPFS
  1. ;4.0*3 10.30.2007 IHS/OIT/FCJ ADDED CSV CHANGES
  1. ;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:"???")
  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:"???")
  1. S X=$P(X,U,6)
  1. I X S:$D(^AUTNPOV(X,0)) X=$P(^AUTNPOV(X,0),U) I 1
  1. E D ENP^XBDIQ1(90001.02,BMCPIEN,".019","BMCX(","E") S:BMCX(".019")]"" X=BMCX(".019")
  1. W ?27,X
  1. W !
  1. S BMCPFH=1
  1. X APCHSCKP
  1. Q
  1. ;
  1. WRTCAT ; WRITE DX/SVC CAT
  1. D WRTCATD
  1. D WRTCATS
  1. Q
  1. ;
  1. WRTCATD ; WRITE DX CAT
  1. D ENP^XBDIQ1(90001,BMCRIEN,".12","BMCX(","E") S X=BMCX(".12")
  1. W "DIAGNOSTIC CATEGORY:",?25,X,!
  1. X APCHSCKP Q:$D(APCHSQIT)
  1. Q
  1. ;
  1. WRTCATS ; WRITE PX CAT
  1. Q ;Remove from HS per Dr. Griffith 11-23-00
  1. D ENP^XBDIQ1(90001,BMCRIEN,".13","BMCX(","E") S X=BMCX(".13")
  1. W "CPT SERVICE CATEGORY:",?25,X,!
  1. X APCHSCKP Q:$D(APCHSQIT)
  1. Q