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

BMC.m

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