BMC ; IHS/PHXAO/TMJ - REFERRED CARE INFO SYSTEM ;
;;4.0;REFERRED CARE INFO SYSTEM;**5,6**;JAN 09, 2006;Build 101
;IHS/ITSC/FCJ CHG TST FOR IOT FOR VIR TRM
;BMC*4.0*6 2.16.2010 IHS.OIT.FCJ ADDED PATCH NUMBER PRINT IN LOGO SUB
;
;
I '$D(ZTQUEUED) W !!,*7,"NO ENTRY FROM THE TOP OF ^BMC.",!
S BMCQ=1
Q
;----------
PARMCHK ;EP - Check RCIS SITE PARAMETER file
; Check/edit RCIS parameters.
S BMCQ=1
S BMCPARM=$G(^BMCPARM(DUZ(2),0))
I BMCPARM="",'$D(ZTQUEUED) W !!,*7,"PARAMETERS NOT SET FOR '",$$LOC,"'. PLEASE ENTER THEM, NOW." D PARMADD S BMCPARM=$G(^BMCPARM(DUZ(2),0))
Q:BMCPARM=""
D BMCFYRY ; set current fiscal year and referral year
I BMCRY="" W !!,*7,"RCIS SITE PARAMETER file REFERRAL YEAR field missing or invalid.",! H 2 Q
I BMCRY'=BMCFY W !!,*7,"RCIS SITE PARAMETER file REFERRAL YEAR does not match current FISCAL YEAR",!,"IGNORE If Operating on Calendar Year Basis..",! H 2
I $P(BMCPARM,U,7)'?1.6N W !!,*7,"RCIS SITE PARAMETER file REFERRAL # field missing or invalid.",! Q
D PARMSET
S BMCQ=0
Q
;----------
PARMSET ;EP - SET SYSTEM WIDE VARIABLES FROM SITE PARAMETER FILE
; Variables set here need to be kill in ^BMCSKILL
S:$G(BMCPARM)="" BMCPARM=$G(^BMCPARM(DUZ(2),0))
I $P(BMCPARM,U,25)="U" S AUPNLK("ALL")="" ;UNIVERSAL/SITE LOOKUP
S BMCPCC=$P(BMCPARM,U,3) ; pcc interface
S BMCCHS=$P(BMCPARM,U,4) ; chs interface
S BMCDXPR=$P(BMCPARM,U,8) ; icd/cpt coding
S BMCDXCPT=$P(BMCPARM,U,27) ; stuff DX & CPT Codes
S BMCLCAT=$P(BMCPARM,U,9) ; local category
S BMCOLOC=$P(BMCPARM,U,11) ; other location
S BMCMGCR=$P($G(BMCPARM),U,26) ; Mged Care Committee
S BMCDMGR=""
S Y=$P(BMCPARM,U,12) S:Y BMCDMGR=$P($G(^VA(200,Y,0)),U) ;dflt case mgr
S BMCCHSS=$P(BMCPARM,U,13) ; chs supervisor
S BMCBOS=$P(BMCPARM,U,14) ; business office supervisor
S BMCCHSA=$P(BMCPARM,U,15) ; chs alert wanted
S BMCIHSA=$P(BMCPARM,U,21) ; ihs alert wanted
S BMCOTHRA=$P(BMCPARM,U,22) ; other alert wanted
S BMCHOUSA=$P(BMCPARM,U,23) ; inhouse alert waned
S BMCPRIO=$P(BMCPARM,U,16)
S BMCDX10=$P(^BMCPARM(DUZ(2),4100),U,11) ;ICD-10 IMPLEMENTATION DATE
; set taxonomy ien's
S BMCTXPHC=$O(^ATXAX("B","BMC POTENTIAL HIGH COST DX",0))
S BMCTXCCP=$O(^ATXAX("B","BMC COSMETIC CPT PROCEDURES",0))
S BMCTXCEX=$O(^ATXAX("B","BMC EXPERIMENTAL CPT PROC",0))
S BMCTXCHC=$O(^ATXAX("B","BMC HIGH COST PROCEDURES",0))
S BMCTXL3P=$O(^ATXAX("B","BMC 3RD PARTY LIABILITY ALERT",0))
; set referral year and fiscal year
D BMCFYRY
Q
;----------
BMCFYRY ; calculate current fiscal year and referral year
S BMCGFY=$P($$FISCAL^XBDT(DT,10),U)
S BMCFY=$E(BMCGFY,3,4)
S BMCRY=$P(BMCPARM,U,2)
Q
;----------
PARMADD ; ADD SITE PARAMETER ENTRY
S DLAYGO=90001.31,DIC(0)="AEMNQL",DIC="^BMCPARM("
D DIC^BMCFMC
Q:+Y<1
S DA=+Y,DIE="^BMCPARM(",DR=".01:999"
D DIE^BMCFMC
Q
;----------
GETR() ;EP - Return referral # from RCIS REFERRAL record
I '$G(BMCRIEN) Q ""
Q $P($G(^BMCREF(BMCRIEN,0)),U,2)
;----------
REFN() ;EP - Return the next referral number and update control file
LOCK +^BMCPARM(DUZ(2)):20 E W:'$D(ZTQUEUED) *7,!!," Unable to lock the RCIS SITE PARAMETER entry for ",$$LOC,".",!! D EOP Q 0
S BMCPARM=$G(^BMCPARM(DUZ(2),0))
S X=$$ASF
S X=X_$P(BMCPARM,U,2)
S Y=$P(BMCPARM,U,7)+1
S X=X_$$LZERO(Y,5)
S BMCX=X
S DIE="^BMCPARM(",DA=DUZ(2),DR=".07////"_Y D DIE^BMCFMC
LOCK -^BMCPARM(DUZ(2)):20
Q BMCX
;----------
REFNFY() ;EP - Get Referral Number for Desired Fiscal Year
S X=$$ASF
;
S X=X_BMCFY_$$LZERO(BMCRNUM,5)
S BMCX=X
Q BMCX
;
LZERO(V,L) ;left zero fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V="0"_V
Q V
;----------
ASF() ;EP - Return ASUFAC number for current DUZ(2).
Q:'$G(DUZ(2)) ""
Q $P($G(^AUTTLOC(DUZ(2),0)),U,10)
;----------
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
DIC(DIC) ;EP - File lookup.
S:'$D(DIC(0)) DIC(0)="AMQN"
D DIC^BMCFMC
Q +Y
;----------
EOP ;EP - End of page.
Q:$E(IOST)'="C"
Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
NEW DIR
K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
S DIR(0)="E" D ^DIR
Q
;----------
USR() ;EP - Return name of current user from ^VA(200.
Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
;----------
HDR ;EP - Screen header DON'S USE ANY LONGER.
Q:$G(XQY0)=""
I '$D(IORVON) S X="IORVON;IORVOFF" D ENDR^%ZISS
S X=$P(XQY0,U,2)
S:X="Referred Care Information System" X="MAIN MENU"
S X=$J("",2*$L(IORVON)-1)_IORVON_X_IORVOFF
W @IOF,!,$$CTR("REFERRED CARE INFORMATION SYSTEM"),!,$$CTR($$LOC()),!,$$CTR(X),!!
Q
;----------
LOCK(DA) ;EP - Lock the selected referral.
LOCK +^BMCREF(DA):20
E W:'$D(ZTQUEUED) *7,!!," This Document Is Currently Being Processed (Document LOCKED).",!! D EOP I 0
Q
;----------
UNLOCK(DA) ;EP - Unlock the selected referral.
LOCK -^BMCREF(DA):20
E W:'$D(ZTQUEUED) *7,!!," UNABLE TO UNLOCK REFERRAL. NOTIFY PROGRAMMER.",!! D EOP I 0
Q
;----------
LOGO ;EP - Print logo of main menu.
NEW A,D,I,L,N,R,V,P,P1 ;BMC*4.0*6 2.16.2010 IHS.OIT.FCJ ADDED P AND P1
S L=18,R=61,D=R-L+1,N=R-L-1
S I=$O(^DIC(9.4,"C","BMC",0)),V=^DIC(9.4,I,"VERSION"),A=$O(^DIC(9.4,I,22,"B",V,0)),Y=$$FMTE^XLFDT($P(^DIC(9.4,I,22,A,0),U,2))
S P=0 F S P=$O(^DIC(9.4,I,22,A,"PAH","B",P)) Q:P'?1.N.N S P1=P ;BMC*4.0*6 2.16.2010 IHS.OIT.FCJ ADDED LINE
;BMC*4.0*6 2.16.2010 IHS.OIT.FCJ SPLIT NEXT LINE REMOVED DATE PRINT AND ADDED PATCH
;W @IOF,!,$$CTR($$REPEAT^XLFSTR("*",D)),!?L,"*",$$CTR("INDIAN HEALTH SERVICE",N),?R,"*",!?L,"*",$$CTR("REFERRED CARE INFORMATION SYSTEM",N),?R,"*",!?L,"*",$$CTR("VERSION "_V_", "_Y,N),?R,"*",!,$$CTR($$REPEAT^XLFSTR("*",D)),!
W @IOF,!,$$CTR($$REPEAT^XLFSTR("*",D)),!?L,"*",$$CTR("INDIAN HEALTH SERVICE",N),?R,"*",!?L,"*",$$CTR("REFERRED CARE INFORMATION SYSTEM",N),?R,"*"
W !?L,"*",$$CTR("VERSION "_V_", Patch "_P1,N),?R,"*",!,$$CTR($$REPEAT^XLFSTR("*",D)),!
W $$CTR($$LOC())
;Sub Menu Displays
Q:$G(XQY0)=""
I '$D(IORVON) S X="IORVON;IORVOFF" D ENDR^%ZISS
S X=$P(XQY0,U,2)
S:X="Referred Care Information System" X="MAIN MENU"
S X=$J("",2*$L(IORVON)-1)_IORVON_X_IORVOFF
W !,$$CTR(X),!
Q
;----------
SEL(S) ;EP - Select a referral to edit, S is DIC("S")
NEW BMC,BMCY,DA,DIC
S:$D(S) DIC("S")=S
S DIC="^BMCREF(",Y=$$DIC(.DIC)
I Y<1 Q Y
S DA=+Y D LOCK(DA) E Q 0
S BMC=DA
I '$D(ZTQUEUED) D
.S DIC="^BMCREF(" D DIQ^BMCFMC
.S DA=$O(^BMCCOM("AD",BMC,0)) I DA S DIC="^BMCCOM(" D DIQ^BMCFMC
.F BMCY=0:0 S BMCY=$O(^BMCDX("AD",BMC,BMCY)) Q:'BMCY S DA=BMCY,DIC="^BMCDX(" D DIQ^BMCFMC
.F BMCY=0:0 S BMCY=$O(^BMCPX("AD",BMC,BMCY)) Q:'BMCY S DA=BMCY,DIC="^BMCPX(" D DIQ^BMCFMC
.D EOP
Q BMC
;----------
DEV ; EP - SELECT OUTPUT DEVICE
S BMCQ=0
S %ZIS="PQ" D ^%ZIS
S:POP BMCQ=1
Q
;----------
PAUSE ; EP - PAUSE FOR USER
Q:$E(IOST)'="C"
Q:$D(ZTQUEUED)!'(IOT["TRM")!$D(IO("S"))
S DIR(0)="E",DIR("A")="Press any key to continue" D ^DIR K DIR
W !
Q
;----------
CONF ; EP - CONFIDENTIAL CLIENT DATA HEADER
W !,$$CTR("*** CONFIDENTIAL PATIENT INFORMATION ***"),!
Q
;----------
TOFAC(R) ; EP - RETURN APPROPRIATE
; 'TO PRIMARY VENDOR/TO IHS FACILITY/TO OTHER PROVIDER'
; R = RCIS REFERRAL IEN
NEW X,Y
S Y=""
G:'$G(R) TOFACX
G:'$D(^BMCREF(R,0)) TOFACX
S X=^BMCREF(R,0)
S Y=$P(X,U,8) I Y S Y=$P(^DIC(4,Y,0),U) G TOFACX
S Y=$P(X,U,7) I Y S Y=$P(^AUTTVNDR(Y,0),U)
I Y="OTHER PROVIDER (NON-CHS)" S Y=$P(X,U,9) I Y S Y=$P(^BMCLPRV(Y,0),U)
TOFACX ;
Q Y
;
;BMC*4.0*5 IHS.OIT.FCJ ADDED READ SECTION ORIGINAL FROM ACHSFU
READ ;EP
K DTOUT,DUOUT,BMCQUIT
N BMCDOIT
S BMCDOIT="R"_" Y:"_DTIME
X BMCDOIT
I '$T S (DTOUT,Y)=""
S:Y="/.," DTOUT=""
S:Y="^" (DUOUT,Y)=""
I $D(DTOUT)!$D(DUOUT) S BMCQUIT=1
Q
;
;BMC*4.0*5 IHS.OIT.FCJ ADDED YN MODULE
YN ;EP
W !!,"Enter a ""Y"" for YES or an ""N"" for NO."
Q
;
ZEROTH(A,B,C,D,E,F,G,H,I,J,K) ;EP - Return 0th node. A is file #, rest fields.
N Z
I '$G(A) Q -1
I '$G(B) Q -1
F Z=67:1:75 Q:'$G(@($C(Z))) S A=+$P($G(^DD(A,B,0)),U,2),B=@($C(Z))
I 'A!('B) Q -1
I '$D(^DD(A,B,0)) Q -1
Q U_$P($G(^DD(A,B,0)),U,2)
BMC ; IHS/PHXAO/TMJ - REFERRED CARE INFO SYSTEM ;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**5,6**;JAN 09, 2006;Build 101
+2 ;IHS/ITSC/FCJ CHG TST FOR IOT FOR VIR TRM
+3 ;BMC*4.0*6 2.16.2010 IHS.OIT.FCJ ADDED PATCH NUMBER PRINT IN LOGO SUB
+4 ;
+5 ;
+6 IF '$DATA(ZTQUEUED)
WRITE !!,*7,"NO ENTRY FROM THE TOP OF ^BMC.",!
+7 SET BMCQ=1
+8 QUIT
+9 ;----------
PARMCHK ;EP - Check RCIS SITE PARAMETER file
+1 ; Check/edit RCIS parameters.
+2 SET BMCQ=1
+3 SET BMCPARM=$GET(^BMCPARM(DUZ(2),0))
+4 IF BMCPARM=""
IF '$DATA(ZTQUEUED)
WRITE !!,*7,"PARAMETERS NOT SET FOR '",$$LOC,"'. PLEASE ENTER THEM, NOW."
DO PARMADD
SET BMCPARM=$GET(^BMCPARM(DUZ(2),0))
+5 IF BMCPARM=""
QUIT
+6 ; set current fiscal year and referral year
DO BMCFYRY
+7 IF BMCRY=""
WRITE !!,*7,"RCIS SITE PARAMETER file REFERRAL YEAR field missing or invalid.",!
HANG 2
QUIT
+8 IF BMCRY'=BMCFY
WRITE !!,*7,"RCIS SITE PARAMETER file REFERRAL YEAR does not match current FISCAL YEAR",!,"IGNORE If Operating on Calendar Year Basis..",!
HANG 2
+9 IF $PIECE(BMCPARM,U,7)'?1.6N
WRITE !!,*7,"RCIS SITE PARAMETER file REFERRAL # field missing or invalid.",!
QUIT
+10 DO PARMSET
+11 SET BMCQ=0
+12 QUIT
+13 ;----------
PARMSET ;EP - SET SYSTEM WIDE VARIABLES FROM SITE PARAMETER FILE
+1 ; Variables set here need to be kill in ^BMCSKILL
+2 IF $GET(BMCPARM)=""
SET BMCPARM=$GET(^BMCPARM(DUZ(2),0))
+3 ;UNIVERSAL/SITE LOOKUP
IF $PIECE(BMCPARM,U,25)="U"
SET AUPNLK("ALL")=""
+4 ; pcc interface
SET BMCPCC=$PIECE(BMCPARM,U,3)
+5 ; chs interface
SET BMCCHS=$PIECE(BMCPARM,U,4)
+6 ; icd/cpt coding
SET BMCDXPR=$PIECE(BMCPARM,U,8)
+7 ; stuff DX & CPT Codes
SET BMCDXCPT=$PIECE(BMCPARM,U,27)
+8 ; local category
SET BMCLCAT=$PIECE(BMCPARM,U,9)
+9 ; other location
SET BMCOLOC=$PIECE(BMCPARM,U,11)
+10 ; Mged Care Committee
SET BMCMGCR=$PIECE($GET(BMCPARM),U,26)
+11 SET BMCDMGR=""
+12 ;dflt case mgr
SET Y=$PIECE(BMCPARM,U,12)
IF Y
SET BMCDMGR=$PIECE($GET(^VA(200,Y,0)),U)
+13 ; chs supervisor
SET BMCCHSS=$PIECE(BMCPARM,U,13)
+14 ; business office supervisor
SET BMCBOS=$PIECE(BMCPARM,U,14)
+15 ; chs alert wanted
SET BMCCHSA=$PIECE(BMCPARM,U,15)
+16 ; ihs alert wanted
SET BMCIHSA=$PIECE(BMCPARM,U,21)
+17 ; other alert wanted
SET BMCOTHRA=$PIECE(BMCPARM,U,22)
+18 ; inhouse alert waned
SET BMCHOUSA=$PIECE(BMCPARM,U,23)
+19 SET BMCPRIO=$PIECE(BMCPARM,U,16)
+20 ;ICD-10 IMPLEMENTATION DATE
SET BMCDX10=$PIECE(^BMCPARM(DUZ(2),4100),U,11)
+21 ; set taxonomy ien's
+22 SET BMCTXPHC=$ORDER(^ATXAX("B","BMC POTENTIAL HIGH COST DX",0))
+23 SET BMCTXCCP=$ORDER(^ATXAX("B","BMC COSMETIC CPT PROCEDURES",0))
+24 SET BMCTXCEX=$ORDER(^ATXAX("B","BMC EXPERIMENTAL CPT PROC",0))
+25 SET BMCTXCHC=$ORDER(^ATXAX("B","BMC HIGH COST PROCEDURES",0))
+26 SET BMCTXL3P=$ORDER(^ATXAX("B","BMC 3RD PARTY LIABILITY ALERT",0))
+27 ; set referral year and fiscal year
+28 DO BMCFYRY
+29 QUIT
+30 ;----------
BMCFYRY ; calculate current fiscal year and referral year
+1 SET BMCGFY=$PIECE($$FISCAL^XBDT(DT,10),U)
+2 SET BMCFY=$EXTRACT(BMCGFY,3,4)
+3 SET BMCRY=$PIECE(BMCPARM,U,2)
+4 QUIT
+5 ;----------
PARMADD ; ADD SITE PARAMETER ENTRY
+1 SET DLAYGO=90001.31
SET DIC(0)="AEMNQL"
SET DIC="^BMCPARM("
+2 DO DIC^BMCFMC
+3 IF +Y<1
QUIT
+4 SET DA=+Y
SET DIE="^BMCPARM("
SET DR=".01:999"
+5 DO DIE^BMCFMC
+6 QUIT
+7 ;----------
GETR() ;EP - Return referral # from RCIS REFERRAL record
+1 IF '$GET(BMCRIEN)
QUIT ""
+2 QUIT $PIECE($GET(^BMCREF(BMCRIEN,0)),U,2)
+3 ;----------
REFN() ;EP - Return the next referral number and update control file
+1 LOCK +^BMCPARM(DUZ(2)):20
IF '$TEST
IF '$DATA(ZTQUEUED)
WRITE *7,!!," Unable to lock the RCIS SITE PARAMETER entry for ",$$LOC,".",!!
DO EOP
QUIT 0
+2 SET BMCPARM=$GET(^BMCPARM(DUZ(2),0))
+3 SET X=$$ASF
+4 SET X=X_$PIECE(BMCPARM,U,2)
+5 SET Y=$PIECE(BMCPARM,U,7)+1
+6 SET X=X_$$LZERO(Y,5)
+7 SET BMCX=X
+8 SET DIE="^BMCPARM("
SET DA=DUZ(2)
SET DR=".07////"_Y
DO DIE^BMCFMC
+9 LOCK -^BMCPARM(DUZ(2)):20
+10 QUIT BMCX
+11 ;----------
REFNFY() ;EP - Get Referral Number for Desired Fiscal Year
+1 SET X=$$ASF
+2 ;
+3 SET X=X_BMCFY_$$LZERO(BMCRNUM,5)
+4 SET BMCX=X
+5 QUIT BMCX
+6 ;
LZERO(V,L) ;left zero fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V="0"_V
+3 QUIT V
+4 ;----------
ASF() ;EP - Return ASUFAC number for current DUZ(2).
+1 IF '$GET(DUZ(2))
QUIT ""
+2 QUIT $PIECE($GET(^AUTTLOC(DUZ(2),0)),U,10)
+3 ;----------
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
DIC(DIC) ;EP - File lookup.
+1 IF '$DATA(DIC(0))
SET DIC(0)="AMQN"
+2 DO DIC^BMCFMC
+3 QUIT +Y
+4 ;----------
EOP ;EP - End of page.
+1 IF $EXTRACT(IOST)'="C"
QUIT
+2 IF $DATA(ZTQUEUED)!'(IOT="TRM")!$DATA(IO("S"))
QUIT
+3 NEW DIR
+4 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+5 SET DIR(0)="E"
DO ^DIR
+6 QUIT
+7 ;----------
USR() ;EP - Return name of current user from ^VA(200.
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
+1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
+2 ;----------
HDR ;EP - Screen header DON'S USE ANY LONGER.
+1 IF $GET(XQY0)=""
QUIT
+2 IF '$DATA(IORVON)
SET X="IORVON;IORVOFF"
DO ENDR^%ZISS
+3 SET X=$PIECE(XQY0,U,2)
+4 IF X="Referred Care Information System"
SET X="MAIN MENU"
+5 SET X=$JUSTIFY("",2*$LENGTH(IORVON)-1)_IORVON_X_IORVOFF
+6 WRITE @IOF,!,$$CTR("REFERRED CARE INFORMATION SYSTEM"),!,$$CTR($$LOC()),!,$$CTR(X),!!
+7 QUIT
+8 ;----------
LOCK(DA) ;EP - Lock the selected referral.
+1 LOCK +^BMCREF(DA):20
+2 IF '$TEST
IF '$DATA(ZTQUEUED)
WRITE *7,!!," This Document Is Currently Being Processed (Document LOCKED).",!!
DO EOP
IF 0
+3 QUIT
+4 ;----------
UNLOCK(DA) ;EP - Unlock the selected referral.
+1 LOCK -^BMCREF(DA):20
+2 IF '$TEST
IF '$DATA(ZTQUEUED)
WRITE *7,!!," UNABLE TO UNLOCK REFERRAL. NOTIFY PROGRAMMER.",!!
DO EOP
IF 0
+3 QUIT
+4 ;----------
LOGO ;EP - Print logo of main menu.
+1 ;BMC*4.0*6 2.16.2010 IHS.OIT.FCJ ADDED P AND P1
NEW A,D,I,L,N,R,V,P,P1
+2 SET L=18
SET R=61
SET D=R-L+1
SET N=R-L-1
+3 SET I=$ORDER(^DIC(9.4,"C","BMC",0))
SET V=^DIC(9.4,I,"VERSION")
SET A=$ORDER(^DIC(9.4,I,22,"B",V,0))
SET Y=$$FMTE^XLFDT($PIECE(^DIC(9.4,I,22,A,0),U,2))
+4 ;BMC*4.0*6 2.16.2010 IHS.OIT.FCJ ADDED LINE
SET P=0
FOR
SET P=$ORDER(^DIC(9.4,I,22,A,"PAH","B",P))
IF P'?1.N.N
QUIT
SET P1=P
+5 ;BMC*4.0*6 2.16.2010 IHS.OIT.FCJ SPLIT NEXT LINE REMOVED DATE PRINT AND ADDED PATCH
+6 ;W @IOF,!,$$CTR($$REPEAT^XLFSTR("*",D)),!?L,"*",$$CTR("INDIAN HEALTH SERVICE",N),?R,"*",!?L,"*",$$CTR("REFERRED CARE INFORMATION SYSTEM",N),?R,"*",!?L,"*",$$CTR("VERSION "_V_", "_Y,N),?R,"*",!,$$CTR($$REPEAT^XLFSTR("*",D)),!
+7 WRITE @IOF,!,$$CTR($$REPEAT^XLFSTR("*",D)),!?L,"*",$$CTR("INDIAN HEALTH SERVICE",N),?R,"*",!?L,"*",$$CTR("REFERRED CARE INFORMATION SYSTEM",N),?R,"*"
+8 WRITE !?L,"*",$$CTR("VERSION "_V_", Patch "_P1,N),?R,"*",!,$$CTR($$REPEAT^XLFSTR("*",D)),!
+9 WRITE $$CTR($$LOC())
+10 ;Sub Menu Displays
+11 IF $GET(XQY0)=""
QUIT
+12 IF '$DATA(IORVON)
SET X="IORVON;IORVOFF"
DO ENDR^%ZISS
+13 SET X=$PIECE(XQY0,U,2)
+14 IF X="Referred Care Information System"
SET X="MAIN MENU"
+15 SET X=$JUSTIFY("",2*$LENGTH(IORVON)-1)_IORVON_X_IORVOFF
+16 WRITE !,$$CTR(X),!
+17 QUIT
+18 ;----------
SEL(S) ;EP - Select a referral to edit, S is DIC("S")
+1 NEW BMC,BMCY,DA,DIC
+2 IF $DATA(S)
SET DIC("S")=S
+3 SET DIC="^BMCREF("
SET Y=$$DIC(.DIC)
+4 IF Y<1
QUIT Y
+5 SET DA=+Y
DO LOCK(DA)
IF '$TEST
QUIT 0
+6 SET BMC=DA
+7 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+8 SET DIC="^BMCREF("
DO DIQ^BMCFMC
+9 SET DA=$ORDER(^BMCCOM("AD",BMC,0))
IF DA
SET DIC="^BMCCOM("
DO DIQ^BMCFMC
+10 FOR BMCY=0:0
SET BMCY=$ORDER(^BMCDX("AD",BMC,BMCY))
IF 'BMCY
QUIT
SET DA=BMCY
SET DIC="^BMCDX("
DO DIQ^BMCFMC
+11 FOR BMCY=0:0
SET BMCY=$ORDER(^BMCPX("AD",BMC,BMCY))
IF 'BMCY
QUIT
SET DA=BMCY
SET DIC="^BMCPX("
DO DIQ^BMCFMC
+12 DO EOP
End DoDot:1
+13 QUIT BMC
+14 ;----------
DEV ; EP - SELECT OUTPUT DEVICE
+1 SET BMCQ=0
+2 SET %ZIS="PQ"
DO ^%ZIS
+3 IF POP
SET BMCQ=1
+4 QUIT
+5 ;----------
PAUSE ; EP - PAUSE FOR USER
+1 IF $EXTRACT(IOST)'="C"
QUIT
+2 IF $DATA(ZTQUEUED)!'(IOT["TRM")!$DATA(IO("S"))
QUIT
+3 SET DIR(0)="E"
SET DIR("A")="Press any key to continue"
DO ^DIR
KILL DIR
+4 WRITE !
+5 QUIT
+6 ;----------
CONF ; EP - CONFIDENTIAL CLIENT DATA HEADER
+1 WRITE !,$$CTR("*** CONFIDENTIAL PATIENT INFORMATION ***"),!
+2 QUIT
+3 ;----------
TOFAC(R) ; EP - RETURN APPROPRIATE
+1 ; 'TO PRIMARY VENDOR/TO IHS FACILITY/TO OTHER PROVIDER'
+2 ; R = RCIS REFERRAL IEN
+3 NEW X,Y
+4 SET Y=""
+5 IF '$GET(R)
GOTO TOFACX
+6 IF '$DATA(^BMCREF(R,0))
GOTO TOFACX
+7 SET X=^BMCREF(R,0)
+8 SET Y=$PIECE(X,U,8)
IF Y
SET Y=$PIECE(^DIC(4,Y,0),U)
GOTO TOFACX
+9 SET Y=$PIECE(X,U,7)
IF Y
SET Y=$PIECE(^AUTTVNDR(Y,0),U)
+10 IF Y="OTHER PROVIDER (NON-CHS)"
SET Y=$PIECE(X,U,9)
IF Y
SET Y=$PIECE(^BMCLPRV(Y,0),U)
TOFACX ;
+1 QUIT Y
+2 ;
+3 ;BMC*4.0*5 IHS.OIT.FCJ ADDED READ SECTION ORIGINAL FROM ACHSFU
READ ;EP
+1 KILL DTOUT,DUOUT,BMCQUIT
+2 NEW BMCDOIT
+3 SET BMCDOIT="R"_" Y:"_DTIME
+4 XECUTE BMCDOIT
+5 IF '$TEST
SET (DTOUT,Y)=""
+6 IF Y="/.,"
SET DTOUT=""
+7 IF Y="^"
SET (DUOUT,Y)=""
+8 IF $DATA(DTOUT)!$DATA(DUOUT)
SET BMCQUIT=1
+9 QUIT
+10 ;
+11 ;BMC*4.0*5 IHS.OIT.FCJ ADDED YN MODULE
YN ;EP
+1 WRITE !!,"Enter a ""Y"" for YES or an ""N"" for NO."
+2 QUIT
+3 ;
ZEROTH(A,B,C,D,E,F,G,H,I,J,K) ;EP - Return 0th node. A is file #, rest fields.
+1 NEW Z
+2 IF '$GET(A)
QUIT -1
+3 IF '$GET(B)
QUIT -1
+4 FOR Z=67:1:75
IF '$GET(@($CHAR(Z)))
QUIT
SET A=+$PIECE($GET(^DD(A,B,0)),U,2)
SET B=@($CHAR(Z))
+5 IF 'A!('B)
QUIT -1
+6 IF '$DATA(^DD(A,B,0))
QUIT -1
+7 QUIT U_$PIECE($GET(^DD(A,B,0)),U,2)
