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

BHSRCIS.m

Go to the documentation of this file. 
  1. 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
  1.  ;===================================================================
  1.  ;Taken from BMCHS
  1.  ; IHS/PHXAO/TMJ - RCIS HEALTH SUMMARY COMPONENT ;
  1.  ;;2.0T1;REFERRED CARE INFO SYSTEM;;NOV 21, 2001
  1.  ;;Health summary routine to get data from REFERRED CARE INFO SYSTEM;;NOV 21, 2001
  1.  ;
  1.  ; This routine generates the RCIS component of the Health Summary.
  1.  ;
  1. HS ;EP-called from health summary
  1.  N X,X1,X2,Y
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W $$CTR^BMC(" <<<  RCIS ACTIVE REFERRALS  >>> ",80),!
  1.  I '$D(^BMCREF("AA",BHSPAT)) D CKP^GMTSUP Q:$D(GMTSQIT)  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",BHSPAT,""),-1)<BMCYAGO D CKP^GMTSUP Q:$D(GMTSQIT)  W !,"No Referred Care Referral records within last year.",! Q
  1.  S BMCRDATE=""
  1.  F  S BMCRDATE=$O(^BMCREF("AA",BHSPAT,BMCRDATE),-1) Q:BMCRDATE<BMCYAGO!($D(GMTSQIT))  D
  1.  .S BMCRIEN=0 F  S BMCRIEN=$O(^BMCREF("AA",BHSPAT,BMCRDATE,BMCRIEN)) Q:'BMCRIEN!($D(GMTSQIT))  D WRTREF
  1. XIT ;
  1.  K DIEN,BMCPFH,BMCPFS,BMCPIEN,BMCYAGO,BMCMCC,BMCCHSCT,BMCDFN,BMCRDATE,BMCREC,BMCRIEN,BMCRIO,BMCRNUMB,BMCRREC,BMCRSTAT,BMCRTYPE,BMCX,BMCDIEN
  1.  Q
  1.  ;
  1. WRTREF ; WRITE RCIS REFERRAL ENTRY
  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.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  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
  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.  D CKP^GMTSUP Q:$D(GMTSQIT)
  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.  D CKP^GMTSUP Q:$D(GMTSQIT)
  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(GMTSQIT)
  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.  D CKP^GMTSUP Q:$D(GMTSQIT)
  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(GMTSQIT)
  1.  Q
  1.  ;
  1. WRTDX2 ; WRITE ONE DX
  1.  S X=^BMCDX(BMCDIEN,0)
  1.  Q:$P(X,U,4)'=BMCPFS
  1.  ;Patch 9
  1.  I $$AICD^BHSUTL D
  1.  .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:"???")
  1.  E  D
  1.  .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:"???")
  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:"???")
  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.  D CKP^GMTSUP
  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.  D CKP^GMTSUP Q:$D(GMTSQIT)
  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(GMTSQIT)
  1.  Q
  1.  ;
  1. WRTPX2 ; WRITE ONE PX
  1.  S X=^BMCPX(BMCPIEN,0)
  1.  Q:$P(X,U,4)'=BMCPFS
  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.  D CKP^GMTSUP
  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.  D CKP^GMTSUP Q:$D(GMTSQIT)
  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.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  Q