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

BMCRD.m

Go to the documentation of this file. 
  1. BMCRD ; IHS/PHXAO/TMJ -VISIT DISPLAY ;        [ 08/29/2006  3:46 PM ]
  1.  ;;4.0;REFERRED CARE INFO SYSTEM;**2,3,8,9,12**;JAN 09, 2006;Build 101
  1.  ;IHS/ITSC/FCJ COMMENT OUT BO COM, DIS COM AND MED HX COM WILL BE
  1.  ;     PRINTED from RCIS COMMENTS File, ALSO MODIFIED THE PRINT FOR
  1.  ;     SEPARATION OF COMMENTS
  1.  ;     ADDED OTHER DENIALS REASONS AND PROVIDERS Modules
  1.  ;BMC*4.0 2/17/05 IHS/ITSC/FCJ ADDED N BMCCTYP
  1.  ;     ADDED DISPLAY OF SUFFIX,REMOVED BOLD ON/OFF VARS
  1.  ;BMC*4.0*2 8/21/06 IHS/OIT/FCJ CHG DISPLAY OF CHS INFO
  1.  ;BMC*4.0*3 8.13.07 IHS.OIT.FCJ PRNT INS AUTH NO AND PRNT MED HX/BO COM FR SEC REF TO PRIM REF
  1.  ;BMC*4.0*8 7.26.12 IHS.OIT.FCJ ADDED DISPLAYING OF DENIAL REASON OPTIONS
  1.  ;BMC*4.0*9 ICD-10 CHANGE
  1.  ;BMC*4.0*12 7.27.17 IHS.OIT.FCJ DISPLAY CALL IN INFO
  1.  ;
  1. EP(BMCRIEN) ;PEP Entry point to build lister array
  1. START ;
  1.  Q:'$D(BMCRIEN)
  1.  Q:'BMCRIEN
  1.  Q:'$D(^BMCREF(BMCRIEN,0))
  1.  K ^TMP("BMCRDSP",$J)
  1.  D BUILD
  1.  D EOJ
  1.  Q
  1.  ;
  1. BUILD ; build array
  1.  K BMCAR N BMCCTYP ;BMC 2/17/05 IHS/ITSC/FCJ ADDED N BMCCTYP
  1.  D TERM^VALM0
  1.  S BMCRREC=^BMCREF(BMCRIEN,0)
  1.  S Y=$P(BMCRREC,U,3) D ^AUPNPAT
  1.  S BMCSTR="",BMCCTR=0
  1.  S BMCH="Patient Name",BMCV=$E($P(^DPT($P(BMCRREC,U,3),0),U),1,20) D BUILD1
  1.  S BMCH="Chart #",BMCV=$S($D(^AUPNPAT($P(BMCRREC,U,3),41,DUZ(2),0)):$P(^(0),U,2),1:"None") D BUILD1
  1.  S BMCH="Date of Birth" S Y=AUPNDOB D DD^%DT S BMCV=Y D BUILD1
  1.  S BMCH="Sex",BMCV=AUPNSEX D BUILD1
  1.  S BMCSTR="" D SET
  1. REFERRAL ;
  1.  S BMCDOS=$$AVDOS^BMCRLU(BMCRIEN,"N")            ;BMC*4.0*9
  1.  S BMCSTR="=============== REFERRAL RECORD ===============",X=(80-$L(BMCSTR)\2) D SET ;$J("",X)_BMCSTR D SET
  1.  K BMCAR D ENP^XBDIQ1(90001,BMCRIEN,".01:.49","BMCAR(","E")
  1.  S F=0 F  S F=$O(BMCAR(F)) Q:F'=+F  I BMCAR(F)]"" D
  1.  .S BMCH=$P(^DD(90001,F,0),U)
  1.  .S BMCV=BMCAR(F)
  1.  .I F=".02" S BMCV=BMCV_$P($G(^BMCREF(BMCRIEN,1)),U)   ;4.0 FCJ
  1.  .D BUILD1
  1.  ;BMC*4.0*3 8.13.07 IHS.OIT.FCJ ADDED NXT LINE
  1.  I $$VAL^XBDIQ1(90001,BMCRIEN,1405)'="" S BMCH="Insurance Auth No",BMCV=$$VAL^XBDIQ1(90001,BMCRIEN,1405) D BUILD1,SET
  1.  S BMCSTR="" D SET
  1.  S BMCH="PURPOSE OF REFERRAL",BMCV=$$VAL^XBDIQ1(90001,BMCRIEN,1201) D BUILD1,SET
  1.  S BMCH="NOTES TO SCHEDULER",BMCV=$$VAL^XBDIQ1(90001,BMCRIEN,1301) D BUILD1,SET
  1.  ;BMC*4.0*12 DISPLAY CALL IN INFO
  1.  I $$VAL^XBDIQ1(90001,BMCRIEN,103)'="" D
  1.  .S BMCH="Call In Notification Date",BMCV=$$VAL^XBDIQ1(90001,BMCRIEN,103) D BUILD1
  1.  .I $$VAL^XBDIQ1(90001,BMCRIEN,104)'="" S BMCH="Call In By",BMCV=$$VAL^XBDIQ1(90001,BMCRIEN,104) D BUILD1
  1.  .D SET
  1. 11 ;11 node display
  1.  ;K BMCAR D ENP^XBDIQ1(90001,BMCRIEN,"1101:1139","BMCAR(","E")  ;BMC*4.0*8
  1.  K BMCAR D ENP^XBDIQ1(90001,BMCRIEN,"1101:1113;1115:1127","BMCAR(","E")
  1.  S F=0 F  S F=$O(BMCAR(F)) Q:F'=+F  I BMCAR(F)]"" D
  1.  .S BMCH=$P(^DD(90001,F,0),U)
  1.  .S BMCV=BMCAR(F)
  1.  .D BUILD1
  1.  ;BMC*4.0*8 ADDED NEXT 6 LINES
  1.  I $$VAL^XBDIQ1(90001,BMCRIEN,1128)'="" S BMCH="Denial Number",BMCV=$$VAL^XBDIQ1(90001,BMCRIEN,1128) D BUILD1
  1.  K BMCAR D ENP^XBDIQ1(90001,BMCRIEN,"1114;6120","BMCAR(","E")
  1.  S F=0 F  S F=$O(BMCAR(F)) Q:F'=+F  I BMCAR(F)]"" D
  1.  .S BMCH=$P(^DD(90001,F,0),U)
  1.  .S BMCV=BMCAR(F)
  1.  .D BUILD1
  1.  ;S BMCSTR="" D SET
  1. 4300 ;OTHER DENIAL REASONS
  1.  K BMCAR D ENPM^XBDIQ1(90001.43,"BMCRIEN,0",".01","BMCAR(")
  1.  S (I,F)=0 F  S I=$O(BMCAR(I)) Q:I'=+I  S BMCSTR="" D SET S F=0 F  S F=$O(BMCAR(I,F)) Q:F'=+F  D
  1.  .S BMCH=$P(^DD(90001.43,F,0),U)
  1.  .S BMCV=BMCAR(I,F)
  1.  .D BUILD1
  1.  .;BMC*4.0*8 ADDED NEXT 2 LINES
  1.  .S BMCV=$P(^BMCREF(BMCRIEN,43,I,0),U,2)
  1.  .I BMCV'="" S BMCV=$P(^ACHSDENS($P(^BMCREF(BMCRIEN,43,I,0),U),20,BMCV,0),U),BMCH="CHS OTH DENIAL REASON OPT:" D BUILD1
  1.  S BMCSTR="" D SET
  1. 4400 ;OTHER DENIAL PROVIDERS
  1.  K BMCAR D ENPM^XBDIQ1(90001.44,"BMCRIEN,0",".01","BMCAR(")
  1.  S (I,F)=0 F  S I=$O(BMCAR(I)) Q:I'=+I  S BMCSTR="" D SET S F=0 F  S F=$O(BMCAR(I,F)) Q:F'=+F  D
  1.  .S BMCH=$P(^DD(90001.44,F,0),U)
  1.  .S BMCV=BMCAR(I,F)
  1.  .D BUILD1
  1.  S BMCSTR="" D SET
  1.  ;BMC*4.0*2 8/28/06 IHS.OIT.FCJ Added nxt section
  1. 6100 ;Display Appeal information in 61 Node
  1.  K BMCAR D ENP^XBDIQ1(90001,BMCRIEN,"6116:6119","BMCAR(","E")
  1.  S F=0 F  S F=$O(BMCAR(F)) Q:F'=+F  I BMCAR(F)]"" D
  1.  .S BMCH=$P(^DD(90001,F,0),U)
  1.  .S BMCV=BMCAR(F)
  1.  .D BUILD1
  1.  S BMCSTR="" D SET
  1.  ;BMC*4.0*2 8/28/06 IHS.OIT.FCJ End of Changes
  1. 14 ;14 Node Display-30 Day Alternate Resource Letter
  1.  K BMCAR D ENP^XBDIQ1(90001,BMCRIEN,"1401:1404","BMCAR(","E")
  1.  S F=0 F  S F=$O(BMCAR(F)) Q:F'=+F  I BMCAR(F)]"" D
  1.  .S BMCH=$P(^DD(90001,F,0),U)
  1.  .S BMCV=BMCAR(F)
  1.  .D BUILD1
  1.  S BMCSTR="" D SET
  1.  ;
  1. 15 ;15 Node Display-Alt Resource Ltr Documentation
  1.  ;
  1.  S BMCSTR="ALTERNATE RESOURCE LETTER:" D SET
  1.  K BMCAR D ENP^XBDIQ1(90001,BMCRIEN,1501,"BMCAR(","E")
  1.  S F=0 F  S F=$O(BMCAR(1501,F)) Q:F'=+F  S BMCSTR=BMCAR(1501,F) D SET
  1.  S BMCSTR="" D SET
  1. 1 ;
  1. 2 ;
  1. 61 ;CHS Eligibility Factors
  1.  K BMCAR D ENP^XBDIQ1(90001,BMCRIEN,"6101:6115","BMCAR(","E")
  1.  ;BMC*4.0*2 8/21/06 IHS/OIT/FCJ CHG DISPLAY OF CHS INFO
  1.  ;S F=0 F  S F=$O(BMCAR(F)) Q:F'=+F  I BMCAR(F)]"" D
  1.  F F=6101,6111,6112,6102,6105,6106,6103,6107,6108,6104,6109,6110,6113,6114,6115 I BMCAR(F)]"" D
  1.  .S BMCH=$P(^DD(90001,F,0),U)
  1.  .S BMCV=BMCAR(F)
  1.  .D BUILD1
  1.  S BMCSTR="" D SET
  1.  ;
  1. 3 ;
  1. LOCAL ;Local Category Display
  1.  ;
  1.  I '$D(^BMCREF(BMCRIEN,21)) G AUTH
  1.  S BMCSTR="LOCAL CATEGORIES:" D SET
  1.  K BMCAR D ENPM^XBDIQ1(90001.21,"BMCRIEN,0",".01","BMCAR(")
  1.  S (I,F)=0 F  S I=$O(BMCAR(I)) Q:I'=+I  S BMCSTR="" D SET S F=0 F  S F=$O(BMCAR(I,F)) Q:F'=+F  D
  1.  .S BMCH=$P(^DD(90001.21,F,0),U)
  1.  .S BMCV=BMCAR(I,F)
  1.  .D BUILD1
  1.  S BMCSTR="" D SET
  1. AUTH ;display authorizations, similiar to v file
  1.  I '$D(^BMCREF(BMCRIEN,41)) G CHSASA
  1.  S BMCSTR="CHS AUTHORIZATIONS:" D SET
  1.  K BMCAR D ENPM^XBDIQ1(90001.41,"BMCRIEN,0",".01:.13","BMCAR(")
  1.  S (I,F)=0 F  S I=$O(BMCAR(I)) Q:I'=+I  S BMCSTR="" D SET S F=0 F  S F=$O(BMCAR(I,F)) Q:F'=+F  D
  1.  .S BMCH=$P(^DD(90001.41,F,0),U)
  1.  .S BMCV=BMCAR(I,F)
  1.  .D BUILD1
  1.  S BMCSTR="" D SET
  1. CHSASA ;
  1.  S BMCSTR="CHS APPROVAL STATUS AUDIT LOG:" D SET
  1.  K BMCAR D ENPM^XBDIQ1(90001.42,"BMCRIEN,0",".01:.05","BMCAR(")
  1.  S (I,F)=0 F  S I=$O(BMCAR(I)) Q:I'=+I  S BMCSTR="" D SET S F=0 F  S F=$O(BMCAR(I,F)) Q:F'=+F  D
  1.  .S BMCH=$P(^DD(90001.42,F,0),U)
  1.  .S BMCV=BMCAR(I,F)
  1.  .D BUILD1
  1.  S BMCSTR="" D SET
  1. VFILES ;set up array of all v file entries
  1.  NEW DA,D0,DIC,DIQ,DR,DI
  1.  S BMCVFLE=90001 F BMCVL=0:0 S BMCVFLE=$O(^DIC(BMCVFLE)) Q:BMCVFLE>90001.09!(BMCVFLE'=+BMCVFLE)  D VF2
  1.  Q
  1.  ;
  1. VF2 ;
  1.  I BMCVFLE="90001.04",$P($G(^BMCREF(BMCRIEN,1)),U)="" D SEC Q  ;4.0 FCJ
  1.  S BMCVNM=$P(^DIC(BMCVFLE,0),U),BMCVDG=^DIC(BMCVFLE,0,"GL"),BMCVIGR=BMCVDG_"""AD"",BMCRIEN,BMCVDFN)",BMCVDFN=""
  1.  I BMCVFLE="90001.03" F BMCCTYP="M","B","C","D","S" D
  1.  .;S BMCVNM=$S(BMCCTYP="M":"Medical Hx Comment",BMCCTYP="B":"Business/CHS Comment",BMCCTYP="C":"Case Review Comment",BMCCTYP="D":"Discharge Comment",1:"")
  1.  .S BMCVNM=$S(BMCCTYP="M":"Medical Hx Comment",BMCCTYP="C":"Case Review Comment",BMCCTYP="D":"Discharge Comment",1:"Business/CHS Comment")
  1.  .S BMCVDFN="",BMCVI=1 F  S BMCVDFN=$O(@BMCVIGR) Q:BMCVDFN=""  D
  1.  ..I $P(^BMCCOM(BMCVDFN,0),U,5)=BMCCTYP D VF3 S BMCVI=2
  1.  E  F BMCVI=1:1 S BMCVDFN=$O(@BMCVIGR) Q:BMCVDFN=""  D VF3
  1.  Q
  1.  ;
  1. VF3 ;
  1.  I BMCVI<2 S BMCSTR="" D SET S BMCSTR="=============== "_BMCVNM_"s ===============",X=(80-$L(BMCSTR)\2) D SET
  1.  K BMCAR D ENP^XBDIQ1(BMCVFLE,BMCVDFN,".01:.019999;.04:999999","BMCAR(","E")
  1.  ;BMC*4.0*9 11-1-12 IHS/OIT/FCJ;NEW LINE FOR ICD-10 CHANGES
  1.  I BMCVFLE="90001.01" D
  1.  .D ENP^XBDIQ1(BMCVFLE,BMCVDFN,".01","BMCAR(","I")
  1.  .S BMCAR(.01)=$P($$ICDDX^ICDEX(BMCAR(.01),BMCDOS,,"E"),U,2)_" - "_$E($P($$ICDDX^ICDEX(BMCAR(.01),BMCDOS,,"E"),U,4),1,50)
  1.  S BMCSTR="" D SET
  1.  S F=0 F  S F=$O(BMCAR(F)) Q:F'=+F  D
  1.  .I $G(BMCAR(F))]"" D
  1.  ..S BMCH=$P(^DD(BMCVFLE,F,0),U)
  1.  ..S BMCV=BMCAR(F)
  1.  ..Q:(BMCVFLE="90001.03")&(F=".05")
  1.  ..D BUILD1
  1.  .S G=0 F  S G=$O(BMCAR(F,G)) Q:G'=+G  I $G(BMCAR(F,G))]"" D
  1.  ..S BMCSTR=BMCAR(F,G)
  1.  ..D SET
  1.  K G
  1.  Q
  1. SEC ;SEC REF INFO ;4.0 FCJ
  1.  ;TEST FOR SECONDARY REF, IF EXIST SET VARS
  1.  ;DATE INITIATE,BY WHO,PROVIDER,EXP APT DATE,PURPOSE,SUF AND NU OF VISITS LEFT
  1.  S BMCRNUMB=$P(^BMCREF(BMCRIEN,0),U,2),BMCTMP=BMCVFLE
  1.  Q:'$D(^BMCREF("S",BMCRNUMB))
  1.  S BMCSTR="" D SET
  1.  S BMCSTR="=============== Secondary Referrals ===============",X=(80-$L(BMCSTR)\2) D SET
  1.  S BMCSUF=0
  1.  W !,BMCRNUMB
  1.  F  S BMCSUF=$O(^BMCREF("S",BMCRNUMB,BMCSUF)) Q:BMCSUF=""  D
  1.  .S BMCSRIEN=0
  1.  .S BMCSRIEN=$O(^BMCREF("S",BMCRNUMB,BMCSUF,BMCSRIEN)) Q:BMCSRIEN'?1N.N  D
  1.  ..S BMCSTR="" D SET
  1.  ..S BMCH="DATE INITIATED",BMCV=$$VAL^XBDIQ1(90001,BMCSRIEN,.01) D BUILD1
  1.  ..S BMCH="USER",BMCV=$$VAL^XBDIQ1(90001,BMCSRIEN,.25) D BUILD1
  1.  ..S BMCH="PROVIDER VENDOR",BMCV=$$VAL^XBDIQ1(90001,BMCSRIEN,.07) D BUILD1
  1.  ..S BMCH="EXP APPT DATE",BMCV=$$VAL^XBDIQ1(90001,BMCSRIEN,1105) D BUILD1
  1.  ..S BMCH="PURPOSE OF REFERRAL",BMCV=$$VAL^XBDIQ1(90001,BMCSRIEN,1201) D BUILD1
  1.  ..S BMCH="SUFFIX",BMCV=$$VAL^XBDIQ1(90001,BMCSRIEN,101) D BUILD1
  1.  ..S BMCH="OUTP VISITS LEFT",BMCV=$$VAL^XBDIQ1(90001,BMCSRIEN,1111) D BUILD1
  1.  ..;BMC*4.0*3 12.13.07 IHS.OIT.FCJ ADDED PRINT MED HX/BO COM FOR SEC REF ON PRIM REF
  1.  ..S BMCVFLE="90001.03"
  1.  ..S BMCVNM=$P(^DIC(BMCVFLE,0),U),BMCVDG=^DIC(BMCVFLE,0,"GL"),BMCVIGR=BMCVDG_"""AD"",BMCSRIEN,BMCVDFN)"
  1.  ..F BMCCTYP="M","S" D
  1.  ...S BMCVDFN="",BMCVI=1
  1.  ...S BMCVNM=$S(BMCCTYP="M":"Sec Ref-"_BMCSUF_" Medical Hx Comment",BMCCTYP="S":"Sec Ref-"_BMCSUF_" Business/CHS Comment",1:"")
  1.  ...F  S BMCVDFN=$O(@BMCVIGR) Q:BMCVDFN=""  D
  1.  ....I $P(^BMCCOM(BMCVDFN,0),U,5)=BMCCTYP D VF3 S BMCVI=2
  1.  ..S BMCVFLE=BMCTMP
  1.  Q
  1. BUILD1 ;
  1.  S BMCSTR=$E(BMCH,1,25)_":",BMCSTR=$$SETSTR^VALM1(BMCV,BMCSTR,28,$L(BMCV))
  1.  D SET
  1.  Q
  1. SET ;set array
  1.  S BMCCTR=BMCCTR+1
  1.  S ^TMP("BMCRDSP",$J,BMCCTR,0)=BMCSTR
  1.  S BMCSTR=""
  1.  Q
  1.  ;
  1. EOJ ;
  1.  K BMCAR,BMCSTR,BMCCTR,BMCH,BMCRREC,BMCV,BMCVNM,BMCVDG,BMCVIGR,BMCVDFN
  1.  N BMCCTYP ;BMC 2/17/05 IHS/ITSC/FCJ ADDED N BMCCTYP
  1.  Q