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

BPCBHSC.m

Go to the documentation of this file. 
  1. BPCBHSC ; IHS/OIT/MJL - BEHAVIORAL HEALTH SPECIAL CROSSREFERENCE FOR GUI ; [ 12/31/2007  10:16 AM ]
  1.  ;;1.5;BPC;**1,4**;OCT 04, 2005
  1.  ;
  1.  ; BPCSETLV - Setting Primary List view - Assumes MH Encounter is central
  1.  ; BPCCTYPE - Screen to Admin Type
  1.  ; BPCGREF  - Primary Global Reference
  1.  ; BPCSBJGR - Subject Global Reference - Used if all of the entries are to be used under this node -- don't need to check a date
  1.  ; BPCDIVAL - Look at all divisions - Not used here, used to screen patients selected prior to calling this routine
  1.  ; BPCBHALL - Look at all users' entries - Only relates to MH REC
  1.  ;
  1. SETUP ;
  1.  S BGUCRFS="",BPCVTYPE=$G(BPCVTYPE)
  1.  S:'$D(BPCGREF) BPCVTYPE=1,BPCGREF="^AMHREC(""AF"",BPCPIEN)"
  1.  S:BGUMAX=25 BGUMAX=0 S BPCLIM=BGUMAX,BGUMAX=999999999 S:'BPCLIM BPCLIM=BGUMAX
  1.  S BPCDIR=1 S:BGUDIR="B" BPCDIR=-1 S BGUDIR=""
  1.  S (BGUBEGIN,BGUEND)="",BPCC=0,BPCGROUP=$G(BPCGROUP),BPCSETLV=$G(BPCSETLV,1),BPCDIVAL=1
  1.  Q
  1.  ;
  1. MHRC ; Get records for a patient by date range
  1.  ;S BPCGREF=$G(BPCGREF,"^AMHREC(""AF"",BPCPIEN)")
  1.  S BPCPIEN=$P(BGUBEGIN,"`"),BGUBEGIN=$P(BGUBEGIN,"`",2)
  1.  D MHREC
  1.  Q
  1.  ;
  1. MHENC ; Get records for an encounter
  1.  I '$D(BGUDRIVR) S BGUDRIVR="MHENC^BPCBHSC",BPCVIEN=BGUBEGIN  D SETUP Q
  1.  D:BPCVIEN'="" MHENCTR
  1.  D KILL
  1.  Q
  1.  ;
  1. MHREC ;
  1.  I '$D(BGUDRIVR) S BGUDRIVR="MHREC^BPCBHSC",BPCSDATE=$P(BGUBEGIN,"`"),BPCVIEN=$P(BGUBEGIN,"`",2),BPCEDATE=$P(BGUEND,"`",1) D SETUP Q
  1.  S BPCVWOPT="2",BPCSBJGR=$G(BPCSBJGR),BPCCTYPE=$G(BPCCTYPE),BPCDTCK=$G(BPCDTCK)
  1.  D MHREC1,KILL
  1.  Q
  1. MHREC1 ;
  1.  D
  1.  .I BPCSDATE'=+BPCSDATE D  Q
  1.  ..S:BPCSDATE="" BPCSDATE="1/1/1980"
  1.  ..S:BPCEDATE="" BPCEDATE="T"
  1.  ..D DT^DILF("",BPCSDATE,.BPCSDAT)
  1.  ..I BPCSDAT=-1 S BPCSDATE="1/1/1980" D DT^DILF("",BPCSDATE,.BPCSDAT)
  1.  ..D DT^DILF("",BPCEDATE,.BPCEDAT)
  1.  ..I BPCEDAT=-1 S BPCEDATE="T" D DT^DILF("",BPCEDATE,.BPCEDAT)
  1.  ..S:BPCDIR<0 BPCEDAT=BPCEDAT+.9999
  1.  .S BPCSDAT=BPCSDATE,BPCEDAT=BPCEDATE
  1.  S BPCCTYPE=$G(BPCCTYPE)
  1.  S BPCC=0,BPCX=0 ;,BPCLIM=$S(BPCVWOPT="0":BPCVWNO,1:999999)
  1.  I BPCDTCK'="" D @BPCDTCK Q
  1.  S BPCX=$S(BPCDIR>0:$O(@BPCGREF@(BPCSDAT),-1),1:$O(@BPCGREF@(BPCEDAT))) F  S BPCX=$O(@BPCGREF@(BPCX),BPCDIR) Q:'BPCX  Q:$S(BPCDIR>0:BPCX\1>BPCEDAT,1:BPCX\1<BPCSDAT)  D  Q:BPCC=BPCLIM
  1.  .F  S BPCVIEN=$O(@BPCGREF@(BPCX,BPCVIEN)) Q:'BPCVIEN  Q:BPCC=BPCLIM  D MHENCTR
  1.  Q
  1.  ;
  1. MHENCTR ;
  1.  ;IHS/CMI/LAB begin mods for UU logic
  1.  I BPCGREF["AMHPSUIC",'$$SFSDE(DUZ,BPCVIEN) Q  ;APPLY SDE LOGIC TO SF FORMS
  1.  ;NEXT LINE CHECKS LOCATION OF ENCOUNTER SCREEN (UU) for group and visits
  1.  I BPCVTYPE S BPCXX=$S(BPCGROUP:$P(^AMHGROUP(BPCVIEN,0),U,5),1:$P(^AMHREC(BPCVIEN,0),U,4)) I $T(ALLOWV^AMHUTIL)]"",'$$ALLOWV^AMHUTIL(DUZ,BPCXX) Q  ;DON'T DISPLAY THIS VISIT
  1.  ;IHS/CMI/LAB end mods for UU logic
  1.  I BPCCTYPE'="",$P(^AMHREC(BPCVIEN,0),U,7)'=BPCCTYPE Q
  1.  S BPCBHALL=1 I BPCVTYPE S BPCBHALL=0,BPCXX=$S(BPCGROUP:$P(^AMHGROUP(BPCVIEN,0),U,5),1:$P(^AMHREC(BPCVIEN,0),U,4)) I BPCXX,$D(^AMHSITE(BPCXX,16,DUZ))!($D(^AMHSITE(DUZ(2),16,DUZ))) S BPCBHALL=1
  1.  ;IHS/CMI/LAB - modified line below to use $$ALLOW instead of checking 19th piece
  1.  I 'BPCBHALL,$S(BPCGROUP:$P(^AMHGROUP(BPCVIEN,0),U,15)'=DUZ,1:'$D(^AMHSITE(DUZ(2),16,DUZ))) S BGUV(BGUFILE,88888)=0 D  Q:'BGUV(BGUFILE,88888)
  1.  .I BPCGROUP D  Q
  1.  ..F  S BGUV(BGUFILE,88888)=$O(^AMHGROUP(BPCVIEN,11,BGUV(BGUFILE,88888))) Q:'BGUV(BGUFILE,88888)  Q:$P(^AMHGROUP(BPCVIEN,11,BGUV(BGUFILE,88888),0),U)=DUZ
  1.  .F  S BGUV(BGUFILE,88888)=$O(^AMHRPROV("AD",BPCVIEN,BGUV(BGUFILE,88888))) Q:'BGUV(BGUFILE,88888)  Q:$P(^AMHRPROV(BGUV(BGUFILE,88888),0),U)=DUZ
  1.  D
  1.  .I 'BPCGROUP D:BPCSETLV  Q  ;PICKUP ALL THESE FIELDS IF BPCSETLV IS SET, INSTEAD OF REQUIRING THEIR OWN FLAGS
  1.  ..S BGUV(BGUFILE,666666)=$O(^AMHREDU("AD",BPCVIEN,0))
  1.  ..S BGUV(BGUFILE,777777)=$O(^AMHRHF("AD",BPCVIEN,0))
  1.  ..S BGUV(BGUFILE,99999)=$O(^AMHRPRO("AD",BPCVIEN,0))
  1.  ..S BGUV(BGUFILE,88888)=0 D
  1.  ...F  S BGUV(BGUFILE,88888)=$O(^AMHRPROV("AD",BPCVIEN,BGUV(BGUFILE,88888))) Q:BGUV(BGUFILE,88888)=""  Q:$P(^AMHRPROV(BGUV(BGUFILE,88888),0),U,4)="P"
  1.  .I BPCSETLV D
  1.  ..S BGUV(BGUFILE,99999)=$O(^AMHGROUP(BPCVIEN,21,0)) S:BGUV(BGUFILE,99999) BGUV(BGUFILE,99999)=$P(^(BGUV(BGUFILE,99999),0),U)
  1.  ..S BGUV(BGUFILE,88888)=0 D
  1.  ..F  S BGUV(BGUFILE,88888)=$O(^AMHGROUP(BPCVIEN,11,BGUV(BGUFILE,88888))) Q:'BGUV(BGUFILE,88888)  I $P(^AMHGROUP(BPCVIEN,11,BGUV(BGUFILE,88888),0),U,2)="P" S BGUV(BGUFILE,88888)=$P(^(0),U) Q
  1.  I BPCSBJGR="" S BGUSUB(1)=BPCVIEN,BGUV(BGUFILE,.0001)=BPCX D FIELDS^BGULIST S BPCC=BGUICNT Q
  1.  S BPCSIEN=0 F  S BPCSIEN=$O(@BPCSBJGR@(BPCSIEN)) Q:'BPCSIEN  S BPCC=BPCC+1,BGUSUB(1)=BPCSIEN,BGUV(BGUFILE,.0001)=BPCX D FIELDS^BGULIST S BPCC=BGUICNT
  1.  Q
  1.  ;
  1. ADM ; Get Administration Entries
  1.  S BPCCTYPE=$O(^AMHTSET("B","ADMINISTRATIVE",""))
  1.  S BPCBHALL=1,BPCGREF="^AMHREC(""B"")",BPCVTYPE=1
  1.  D MHREC
  1.  Q
  1.  ;
  1. MHCASE ;
  1.  S BPCGREF="^AMHPCASE(""C"",BPCPIEN)",BPCDTCK="MHCASE1"
  1.  D MHRC
  1.  Q
  1.  ;
  1. MHCASE1 ;
  1.  ;IHS/CMI/LAB - added $$CDSDE check
  1.  S BPCVIEN=0 F  S BPCVIEN=$O(@BPCGREF@(BPCVIEN)) Q:'BPCVIEN  Q:BPCC=BPCLIM  S BPCX=$P(^AMHPCASE(BPCVIEN,0),U,1) I BPCX'<BPCSDAT,BPCX'>BPCEDAT,$$CDSDE(DUZ,BPCVIEN) D MHENCTR
  1.  Q
  1.  ;
  1. MHTREAT ;
  1.  S BPCGREF="^AMHPTXP(""AC"",BPCPIEN)",BPCDTCK="MHTREAT1",BPCSETLV=""
  1.  D MHRC
  1.  Q
  1.  ;
  1. MHTREAT1 ;
  1.  ;IHS/CMI/LAB - added $$TPSDE check
  1.  S BPCVIEN=0 F  S BPCVIEN=$O(@BPCGREF@(BPCVIEN)) Q:'BPCVIEN  Q:BPCC=BPCLIM  S BPCX=$P(^AMHPTXP(BPCVIEN,0),U,1) I BPCX'<BPCSDAT,BPCX'>BPCEDAT,$$TPSDE(DUZ,BPCVIEN) D MHENCTR
  1.  Q
  1.  ;
  1. MHSUIV ;
  1.  S BPCGREF="^AMHPSUIC(""AD"")",BPCSETLV=""
  1.  D MHREC
  1.  Q
  1.  ;
  1. MHSUI ;
  1.  S BPCGREF="^AMHPSUIC(""AC"",BPCPIEN)",BPCDTCK="MHSUI1",BPCSETLV=""
  1.  D MHRC
  1.  Q
  1.  ;
  1. MHSUI1 ;
  1.  ;IHS/CMI/LAB - added $$SFSDE check
  1.  S BPCVIEN=0 F  S BPCVIEN=$O(@BPCGREF@(BPCVIEN)) Q:'BPCVIEN  Q:BPCC=BPCLIM  S BPCX=$P(^AMHPSUIC(BPCVIEN,0),U,6) I BPCX'<BPCSDAT,BPCX'>BPCEDAT,$$SFSDE(DUZ,BPCVIEN) D MHENCTR
  1.  Q
  1.  ;
  1. HF ; Health Factors
  1.  S BPCSBJGR="^AMHRHF(""AD"",BPCVIEN)",BPCSETLV=0,BPCCTYPE=""
  1.  D MHENC
  1.  Q
  1.  ;
  1. EDU ; Patient Education
  1.  S BPCSBJGR="^AMHREDU(""AD"",BPCVIEN)",BPCSETLV=0,BPCCTYPE=""
  1.  D MHENC
  1.  Q
  1.  ;
  1. MHGRP ;
  1.  S BPCGREF="^AMHGROUP(""B"")",BPCGROUP=1,BPCVTYPE=1
  1.  D MHREC
  1.  Q
  1.  ;
  1. KILL ;
  1.  K BGUDRIVR,BPCC,BPCCTYPE,BPCDIVAL,BPCDTCK,BPCEDATE,BPCGREF,BPCGROUP,BPCBHALL,BPCLBONL,BPCLIM,BPCPIEN,BPCSBJGR,BPCSDATE,BPCSETLV,BPCSIEN,BPCVIEN,BPCVTYPE,BPCVWNO,BPCVWOPT,BPCX,BPCXX
  1.  Q
  1. CDSDE(P,I) ;can user P see this case status record per SDE parameter?
  1.  I $D(^AMHSITE(DUZ(2),16,P)) Q 1  ;allow all with access
  1.  I $P(^AMHPCASE(I,0),U,8)=P Q 1
  1.  Q 0
  1.  ;
  1. TPSDE(P,I) ;can user P see this treatment plan per SDE parameters?
  1.  I $D(^AMHSITE(DUZ(2),16,P)) Q 1  ;allow all with access
  1.  I $P(^AMHPTXP(I,0),U,4)=P Q 1
  1.  Q 0
  1.  ;
  1. SFSDE(P,I) ;
  1.  I $D(^AMHSITE(DUZ(2),16,P)) Q 1  ;allow all with access
  1.  I $P(^AMHPSUIC(I,0),U,3)=P Q 1  ;allow your own
  1.  Q 0
  1.  ;
  1. ALLOW(R) ;
  1.  I $D(^AMHSITE(DUZ(2),16,DUZ)) Q 1  ;allow all with access
  1.  NEW X,G S G=0 S X=0 F  S X=$O(^AMHRPROV("AD",R,X)) Q:X'=+X  I $P(^AMHRPROV(X,0),U)=DUZ S G=1
  1.  I G Q 1
  1.  I $P(^AMHREC(R,0),U,19)=DUZ Q 1
  1.  Q 0