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