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