AMHUTIL ; IHS/CMI/LAB - UTILITIES ;
;;4.0;IHS BEHAVIORAL HEALTH;**4**;JUN 18, 2010;Build 28
;
GUIPL(P,R,Z) ;EP - called from GUI for patient lookup
I '$G(P) Q 0
I '$G(R) S R=$G(DUZ)
I '$G(R) Q 0
I '$G(Z) S Z=DUZ(2)
I '$G(Z) Q 0
;first check to see if patient has a HRN at DUZ(2) and it is not inactive, if they don't then quit cause we're done,
;they should log in to the site they want the patient from
I '$D(^AUPNPAT(P,41,Z,0)) Q 0
I $P($G(^AUPNPAT(P,41,Z,0)),U,2)="" Q 0
I $P(^AUPNPAT(P,41,Z,0),U,3) Q 0
;now do the UU junk
Q $$ALLOWP(R,P)
;
DV4() ;EP
;get date version 4.0 installed
NEW X,Y
S X=$O(^DIC(9.4,"C","AMH",0))
I X="" Q ""
S Y=$O(^DIC(9.4,X,22,"B","4.0",0))
I Y="" Q ""
Q $P($G(^DIC(9.4,X,22,Y,0)),U,3)
;
SSN(P) ;EP
I '$G(P) Q ""
I '$D(^DPT(P,0)) Q ""
Q $S($L($P(^DPT(P,0),U,9))=9:$J("XXX-XX-"_$E($P(^DPT(P,0),U,9),6,9),11),1:$J($P(^DPT(P,0),U,9),11))
;
ALLOWVI(P,V) ;EP - is user P allowed to see VISIT V
;P - DUZ, user internal entry number
I '$G(P) Q 0
I '$G(V) Q 0
I '$D(^AMHBHUSR(P,0)) Q $$ALLOWSDE(P,V) ;user is not in BH User file so allow
; access to all visits
I '$O(^AMHBHUSR(P,11,0)) Q $$ALLOWSDE(P,V) ;no locations so allow all
NEW R
S R=$P($G(^AMHREC(V,0)),U,4) ;get location of encounter
I 'R Q $$ALLOWSDE(P,V) ;if no location, don't allow
I $D(^AMHBHUSR(P,11,R)) Q $$ALLOWSDE(P,V) ;if location R is in the list of allowed
; locations then allow this visit to be seen by this user
Q 0
ALLOWSDE(P,R) ;EP - is user allowed to see this visit based on "SDE" logic
I '$G(P) Q ""
I $D(^AMHSITE(DUZ(2),16,P)) Q 1 ;allow all with access
NEW X,G,Z S G=0 S X=0 F S X=$O(^AMHRPROV("AD",R,X)) Q:X'=+X I $P(^AMHRPROV(X,0),U)=P S G=1
I G Q 1
I $P(^AMHREC(R,0),U,19)=P Q 1
S G=0
S X=0 F S X=$O(^AMHREC(R,54,"B",X)) Q:X'=+X D
.S Z=$P($G(^TIU(8925,X,12)),U,2) I Z=P S G=1
I G Q 1
Q 0
;
ALLOWPCC(P,V) ;EP - is user P allowed to see VISIT V
I '$G(P) Q 0
I '$G(V) Q 0
I '$D(^AMHBHUSR(P,0)) Q $$PCCSDE(P,V) ;user is not in BH User file so allow
; access to all visits
I '$O(^AMHBHUSR(P,11,0)) Q $$PCCSDE(P,V) ;no locations so allow all
NEW R
S R=$P($G(^AUPNVSIT(V,0)),U,6) ;get location of encounter
I 'R Q $$ALLOWSDE(P,V) ;if no location, don't allow
I $D(^AMHBHUSR(P,11,R)) Q $$PCCSDE(P,V) ;if location R is in the list of allowed
; locations then allow this visit to be seen by this user
;check patient on the visit?
NEW S S S=$P(^AUPNVSIT(V,0),U,5)
I S,'$$ALLOWP(P,S) Q 0
Q $$PCCSDE(P,V) ;otherwise, don't allow them to see it
;
PCCSDE(P,R) ;EP - is user allowed to see this visit based on "SDE" logic
I '$G(P) Q ""
I $D(^AMHSITE(DUZ(2),16,P)) Q 1 ;allow all with access
NEW X,G S G=0 S X=0 F S X=$O(^AUPNVPRV("AD",R,X)) Q:X'=+X I $P(^AUPNVPRV(X,0),U)=P S G=1
I G Q 1
I $P(^AUPNVSIT(R,0),U,23)=P Q 1
Q 0
;
ALLOWV(P,R) ;EP - is user P allowed to see a visit from location R
;P - DUZ, user internal entry number R - ien of location from file 9999999.06
I '$D(^AMHBHUSR(P,0)) Q 1 ;user is not in BH User file so allow
; access to all visits
I '$O(^AMHBHUSR(P,11,0)) Q 1 ;no locations so allow all
I 'R Q 0 ;no valid location passed in so don't allow visit
I $D(^AMHBHUSR(P,11,R)) Q 1 ;if location R is in the list of allowed
; locations then allow this visit to be seen
Q 0
;
ALLOWP(P,R) ;EP - is user P allowed to see patient R?
I '$D(^AMHBHUSR(P,0)) Q 1 ;user is not in BH User file so allow
; access to all patients
I 'R Q 0 ;no valid location passed in so don't allow
; access to this patient
I '$O(^AMHBHUSR(P,11,0)) Q 1 ;no locations so allow all
NEW G,X S G=0
S X=0 F S X=$O(^AMHBHUSR(P,11,X)) Q:X'=+X I $D(^AUPNPAT(R,41,X)) S G=1 ;has a hrn
I G Q 1 ;if patient has HRN at facility any facility in the BH USer file
; then allow access to this patient
Q 0
;
EHR(R) ;EP - called to determine if this is an EHR created visit
I '$G(R) Q ""
Q $P($G(^AMHREC(R,11)),U,10)
;
NALLOWP ;EP - called to write a notification to the user
D EN^DDIOL("***** You do not have access to that patient's record, see your supervisor.","","!!")
Q
;
DBHUSR ;EP - note to user
Q:'$D(^AMHBHUSR(DUZ,0))
Q:'$O(^AMHBHUSR(DUZ,11,0))
NEW X
S X=$G(IORVON)_"Please note:"_$G(IORVOFF)_" Only visits to the following locations will"
D EN^DDIOL(X,,"!!")
D EN^DDIOL("be displayed:",,"!?14")
S X=0 F S X=$O(^AMHBHUSR(DUZ,11,X)) Q:X'=+X D EN^DDIOL($P(^DIC(4,X,0),U),,"!?15")
D EN^DDIOL("",,"!!")
Q
DBHUSRP ;EP - note to user
Q:'$D(^AMHBHUSR(DUZ,0))
Q:'$O(^AMHBHUSR(DUZ,11,0))
NEW X
S X=$G(IORVON)_"Please note:"_$G(IORVOFF)_" Only patients who have HRN's at the following "
D EN^DDIOL(X,,"!")
D EN^DDIOL("locations will be included in this report:",,"!?14")
S X=0 F S X=$O(^AMHBHUSR(DUZ,11,X)) Q:X'=+X D EN^DDIOL($P(^DIC(4,X,0),U),,"!?15")
D EN^DDIOL("",,"!")
Q
ACTPROV(Y) ;EP called from data dictionary
NEW D S D=""
I '$D(^VA(200,"AK.PROVIDER",$P(^VA(200,Y,0),U),Y)) Q 0 ;not a provider - no provider key
S D=$S($G(AMHDATE)]"":$P(AMHDATE,"."),1:"")
I D="",$G(DA),$P($G(^AMHRPROV(DA,0)),U,3)]"" S D=$P($P(^AMHREC($P(^AMHRPROV(DA,0),U,3),0),U),".")
I $P($G(^VA(200,Y,"PS")),U,4)]"",$P($G(^VA(200,Y,"PS")),U,4)<D Q 0
Q 1
XTMP(N,D) ;EP -set xtmp( 0 node
Q:$G(N)=""
S ^XTMP(N,0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_$G(D)
Q
PPINI(AMHUREC) ;EP Retrieve BH Primary Provider Initials
NEW X,Y,AMHX,AMHY,DIQ,DR,DA,AMHG,AMHINI,AMHGR
S AMHG="^AMHRPROV("
S AMHX=0,AMHGR=AMHG_"""AD"",AMHUREC,AMHX)" F S AMHX=$O(@AMHGR) Q:AMHX'=+AMHX I $P(@(AMHG_AMHX_",0)"),U,4)="P" S AMHY=$P(^(0),U)
I '$D(AMHY) S AMHINI="???" Q AMHINI
S AMHINI=$$VAL^XBDIQ1(200,AMHY,1)
S:AMHINI="" AMHINI="???"
Q AMHINI
PPNAME(AMHUREC) ;EP
NEW X,Y,AMHX,AMHY,DIQ,DR,DA,AMHG,AMHNAME,AMHGR
S AMHG="^AMHRPROV("
S AMHX=0,AMHGR=AMHG_"""AD"",AMHUREC,AMHX)" F S AMHX=$O(@AMHGR) Q:AMHX'=+AMHX I $P(@(AMHG_AMHX_",0)"),U,4)="P" S AMHY=$P(^(0),U)
I '$D(AMHY) S AMHNAME="???" Q AMHNAME
S AMHNAME=$P(^VA(200,AMHY,0),U)
S:AMHNAME="" AMHNAME="???"
Q AMHNAME
PPINT(R) ;EP primary provider internal # from 200
NEW %,%1
S %=0,%1="" F S %=$O(^AMHRPROV("AD",R,%)) Q:%'=+% I $P(^AMHRPROV(%,0),U,4)="P" S %1=$P(^AMHRPROV(%,0),U)
Q %1
PPAFFL(AMHUREC,AMHFORM) ;EP - get pp affiliation internal or external
NEW X,Y,AMHX,AMHY,DIQ,DR,DA,AMHG,AMHAFFL,AMHGR
S AMHG="^AMHRPROV("
S AMHX=0,AMHGR=AMHG_"""AD"",AMHUREC,AMHX)" F S AMHX=$O(@AMHGR) Q:AMHX'=+AMHX I $P(@(AMHG_AMHX_",0)"),U,4)="P" S AMHY=$P(^(0),U)
I '$D(AMHY) S AMHAFFL="?" Q AMHAFFL
S DA=AMHY,DIC=200,DR=9999999.01,DIQ="AMHAFFL" S:$G(AMHFORM)="I" DIQ(0)="I"
D EN^DIQ1
S AMHAFFL=$S($G(AMHFORM)="I":AMHAFFL(200,AMHY,9999999.01,"I"),1:AMHAFFL(200,AMHY,"9999999.01"))
S:AMHAFFL="" AMHAFFL="?"
Q AMHAFFL
PPCLS(AMHUREC,AMHFORM) ;EP GET primary provider discipline
NEW X,Y,AMHX,AMHY,DIQ,DR,DA,AMHG,AMHCLS,AMHGR
S AMHG="^AMHRPROV("
S AMHX=0,AMHGR=AMHG_"""AD"",AMHUREC,AMHX)" F S AMHX=$O(@AMHGR) Q:AMHX'=+AMHX I $P(@(AMHG_AMHX_",0)"),U,4)="P" S AMHY=$P(^(0),U)
I '$D(AMHY) S AMHCLS="??" Q AMHCLS
S DA=AMHY,DIC=200,DR=53.5,DIQ="AMHCLS" S:$G(AMHFORM)="I" DIQ(0)="I"
D EN^DIQ1
S AMHCLS=$S($G(AMHFORM)="I":$G(AMHCLS(200,AMHY,53.5,"I")),1:$G(AMHCLS(200,AMHY,"53.5")))
S:AMHCLS="" AMHCLS="??"
Q AMHCLS
PPCLSC(AMHUREC) ;EP GET PRIMARY PROVIDER CLASS CODE
NEW X,Y,AMHCODE,DIC,DR,DA,DIQ,AMHCLS
S AMHCLS=$$PPCLS^AMHUTIL(AMHUREC,"I")
I AMHCLS="??" S AMHCODE="??" Q AMHCODE
S DIC=7,DR="9999999.01",DA=AMHCLS,DIQ="AMHCODE"
D EN^DIQ1
S AMHCODE=AMHCODE(7,AMHCLS,"9999999.01")
S:AMHCODE="" AMHCODE="??"
Q AMHCODE
;
IN ;EP - called from input transform on .32 field
Q:X=""
Q:$E(X)'="I"
NEW P S P=$P(^AMHREC(DA,0),U,8)
Q:'$D(^AMHREC("AIN",P,"IN"))
I $O(^AMHREC("AIN",P,"IN",0))=DA Q
D EN^DDIOL("This Patient Already has an Initial Intake Record.")
K X
Q
DIFF ;EP - called from screenman
I $G(DA)="" Q
I $$GET^DDSVAL(9002011.06,DA,.21)=$$GET^DDSVAL(9002011.06,DA,.22) D PUT^DDSVAL(9002011.06,DA,.23,""),UNED^DDSUTL("DIFFERENCE REASON",3,1,1) Q
D UNED^DDSUTL("DIFFERENCE REASON",3,1,0)
Q
SMK(A) ;EP - called from screen
I '$D(^AUTTHF(A,0)) Q 0
I $P(^AUTTHF(A,0),U,10)'="F" Q 0
NEW B S B=$O(^AUTTHF("B","TOBACCO",0)) I 'B Q 0
I $P(^AUTTHF(A,0),U,3)'=B Q 0
Q 1
;
STAGE(R) ;EP called from screenman
I '$G(R) Q ""
NEW %,%1,%2,%3,V
S (%,%1,%2,%3)=0
F %=.12:.01:.18 S V=$$GET^DDSVAL(9002011.06,R,%) S:V %1=%1+V,%2=%2+1
I '%2 Q 0
Q $J((%1/%2),3,1)
ICDN(CIM) ;EP
I $G(CIM)="" Q ""
NEW X,Y,Z
S Z=$P(^AMHPROB(CIM,0),U,5)
I Z="" Q ""
I $T(ICDDX^ICDEX)="" S X=+$$CODEN^ICDCODE(Z,80)
I $T(ICDDX^ICDEX)]"" S X=+$$CODEN^ICDEX(Z,80)
I 'X!(X=-1) Q ""
I $T(ICDDX^ICDEX)="" S Y=$E($P($$ICDDX^ICDCODE(X),U,4),1,25)
I $T(ICDDX^ICDEX)]"" S Y=$E($P($$ICDDX^ICDEX(X),U,4),1,25)
Q Y
DATE(D) ;EP - return YYYYMMDD from internal fm format
I $G(D)="" Q ""
Q ($E(D,1,3)+1700)_$E(D,4,7)
UIDV(REC) ;EP - generate unique ID for visit
I '$G(REC) Q REC
NEW X
S X=$$GET1^DIQ(9999999.06,$P(^AUTTSITE(1,0),U),.32)
Q X_$$LZERO(REC,10)
;
LZERO(V,L) ;EP - left zero fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V="0"_V
Q V
POSTDA ;EP - called from screeNMAN
D REQ^DDSUTL(14,2,1,$S(X=1:1,X=2:1,X=4:1,1:0))
D REQ^DDSUTL(15,2,1,$S(X=3:1,X=5:1,1:0))
I X=1!(X=2)!(X=4) D PUT^DDSVAL(DIE,.DA,.17,"",,"I")
I X=3!(X=5) D PUT^DDSVAL(DIE,.DA,.16,"",,"I")
Q
CHART(V) ;EP - returns ASUFAC_HRN
NEW L,%,C,S,P,Z
S %=""
I '$D(^AMHREC(V,0)) Q %
S Z=^AMHREC(V,0)
S P=$P(Z,U,8)
I 'P Q %
I $P(Z,U,4),$D(^AUPNPAT(P,41,$P(Z,U,4),0)) S L=$P(Z,U,4) S %=$$GETCHART(L) I %]"" Q %
I $G(DUZ(2)) S L=DUZ(2) S %=$$GETCHART(L)
I %="" S L=$O(^AUPNPAT(P,41,0)) I L S %=$$GETCHART(L)
I %="" S %=" ??????"
Q %
GETCHART(L) ;
S S=$P(^AUTTLOC(L,0),U,10)
I S="" Q S
S C=$P($G(^AUPNPAT(P,41,L,0)),U,2)
I C="" Q C
S C=$E("000000",1,6-$L(C))_C
S %=S_C
Q %
;
PRIMPROV(V,F) ;EP - primary provider in many different formats
I 'V Q ""
I '$D(^AMHREC(V)) Q ""
NEW %,Y,P,Z
S P="",Y=0 F S Y=$O(^AMHRPROV("AD",V,Y)) Q:Y'=+Y I $P(^AMHRPROV(Y,0),U,4)="P" S P=$P(^AMHRPROV(Y,0),U),Z=Y
I 'P Q P
I '$D(^VA(200,P)) Q ""
I $G(F)="" S F="N"
S %="" D @F
Q %
;
SECPROV(V,N,F) ;EP
I 'V Q ""
I '$D(^AUPNVSIT(V)) Q ""
I '$G(N) Q ""
NEW %,Y,P,Z
S P="",(C,Y)=0 F S Y=$O(^AMHRPROV("AD",V,Y)) Q:Y'=+Y I $P(^AMHRPROV(Y,0),U,4)'="P" S C=C+1 I C=N S P=$P(^AMHRPROV(Y,0),U),Z=Y
I 'P Q P
I '$D(^VA(200,P)) Q ""
I $G(F)="" S F="N"
S %="" D @F
Q %
;
PROV ;EP
NEW Z,C,%,S
S (C,Y)=0 F S Y=$O(^AMHRPROV("AD",V,Y)) Q:Y'=+Y S C=C+1 S APCLV(C)="",P=$P(^AMHRPROV(Y,0),U) D
.I F=99 D Q
..F I=1:1 S S=$T(@I) Q:S="" S %="" D @I S $P(APCLV(C),U,I)=%
.I F[";" D Q
..F J=1:1 S I=$P(F,";",J) Q:I="" I I'=99 S %="" D @I S $P(APCLV(C),U,J)=%
.S %="",I=F D @I S $P(APCLV(C),U)=%
.Q
Q
METHOD(SFIEN) ;EP - called from export
I '$G(SFIEN) Q ""
NEW X,Y,Z,C,D,A,B
S C=0,D=0
S X=0,Y="" F S X=$O(^AMHPSUIC(SFIEN,11,X)) Q:X'=+X D
.S C=C+1
.I C=1 S $P(Y,U)=$P(^AMHPSUIC(SFIEN,11,X,0),U)
.I C=2 S $P(Y,U,2)=$P(^AMHPSUIC(SFIEN,11,X,0),U)
.I $P(^AMHPSUIC(SFIEN,11,X,0),U)=8,$P(^AMHPSUIC(SFIEN,11,X,0),U,2)]"" S $P(Y,U,3)=$S($P(Y,U,3)]"":" ",1:""),$P(Y,U,3)=$P(Y,U,3)_$P(^AMHPSUIC(SFIEN,11,X,0),U,2)
.I $P(^AMHPSUIC(SFIEN,11,X,0),U)=7 D
..S A=0 F S A=$O(^AMHPSUIC(SFIEN,11,X,11,A)) Q:A'=+A D
...S D=D+1 Q:D>2 S P=D+3 S Z=$P(^AMHPSUIC(SFIEN,11,X,11,A,0),U,1) I Z S Z=$P(^AMHTSDRG(Z,0),U),$P(Y,U,P)=Z
.Q
Q Y
SUB(SFIEN) ;EP
I '$G(SFIEN) Q ""
NEW X,Y,Z,C,D,J
S C=0,D=2,E=0
S $P(Y,U)=$P(^AMHPSUIC(SFIEN,0),U,26)
S J=0,E=0 F S J=$O(^AMHPSUIC(SFIEN,15,J)) Q:J'=+J D
.S E=E+1 Q:E>2 S Z=$P(^AMHPSUIC(SFIEN,15,J,0),U) I Z S Z=$P(^AMHTSSU(Z,0),U) S D=D+1 S $P(Y,U,D)=Z
.Q
Q Y
CONTRIB(SFIEN) ;EP
I '$G(SFIEN) Q ""
NEW X,Y,Z,C
S C=0,X=0,Y="" F S X=$O(^AMHPSUIC(SFIEN,13,X)) Q:X'=+X D
.S C=C+1,Z=$P(^AMHPSUIC(SFIEN,13,X,0),U) I Z S Z=$P(^AMHTSCF(Z,0),U) S $P(Y,U,C)=Z
.Q
Q Y
REFCHK ;EP - called from screenman to check placement disp and referred to
NEW A,B
S A=$$GET^DDSVAL(DIE,DA,.17)
S B=$$GET^DDSVAL(DIE,DA,.18)
I A]"",B="" D EN^DDIOL("If Placement Disposition is entered, Referred to is Required.") S DDSBR="1^1^2.2" Q
I A="",B]"" D EN^DDIOL("If Referred to is entered, Placement Disposition is Required.") S DDSBR="19^2^1" Q
Q
REFED ;EP - called from screenman to check placement disp and referred to
NEW A,B
S A=$$GET^DDSVAL(DIE,DA,.17)
S B=$$GET^DDSVAL(DIE,DA,.18)
I A]"",B="" D EN^DDIOL("If Placement Disposition is entered, Referred to is Required.") S DDSBR="1^1^2.2" Q
I A="",B]"" D EN^DDIOL("If Referred to is entered, Placement Disposition is Required.") S DDSBR="29^2^1" Q
Q
LISTAT ;EP - called from executable help from activity type
NEW A,B,C
S A=0 F S A=$O(^AMHTACT("AC",A)) Q:A="" D
.S B=0 F S B=$O(^AMHTACT("AC",A,B)) Q:B'=+B D
..D EN^DDIOL($P(^AMHTACT(B,0),U,1)_" "_$P(^AMHTACT(B,0),U,2),"","!")
.Q
Q
SETBAA ;EP
I '$D(X) Q
I $L($P(X,".",1))<3 S ^AMHPROB("BAA",X,DA)="" Q
I $E(X)="0" S ^AMHPROB("BAA",X,DA)="" Q
I $E(X)="V" S ^AMHPROB("BAA",X,DA)="" Q
S ^AMHPROB("BAA",$$RBLK^AMHLEDV(X,7),DA)="" Q
Q
KILLBAA ;EP
I '$D(X) Q
I $L($P(X,".",1))<3 K ^AMHPROB("BAA",X,DA) Q
I $E(X)="0" K ^AMHPROB("BAA",X,DA) Q
I $E(X)="V" K ^AMHPROB("BAA",X,DA) Q
K ^AMHPROB("BAA",$$RBLK^AMHLEDV(X,7),DA) Q
Q
;
I ;EP
S %=P Q
T ;EP
S %=$P($G(^VA(200,P,0)),U,2) Q
A ;EP
S %=$P($G(^VA(200,P,9999999)),U) Q
B ;EP
S %=$P($G(^VA(200,P,9999999)),U)
Q:%=""
S %=$$EXTSET^XBFUNC(200,9999999.01,%)
Q
D ;EP
D F
Q:%=""
S %=$P($G(^DIC(7,%,9999999)),U)
Q
;
E ;EP
S %=$$VAL^XBDIQ1(200,P,53.5)
Q
F ;EP
S %=$$VALI^XBDIQ1(200,P,53.5)
Q
C ;EP
S %=$P($G(^VA(200,P,9999999)),U,2) Q
N ;EP
S %=$P($G(^VA(200,P,0)),U) Q
O ;EP
NEW A D A Q:%="" S A=%,%="" D D Q:%="" S %=A_% Q
P ;EP
NEW A D A Q:%="" S A=% NEW D D D Q:%="" S D=%,%="" D C Q:%="" S %=A_D_% Q
1 ;
S %=$$VD^APCLV($P(^AMHRPROV(Y,0),U,3),"I")
Q
2 ;
S %=$$VD^APCLV($P(^AMHRPROV(Y,0),U,3),"S")
Q
3 ;
S %=$P(^AMHRPROV(Y,0),U,2)
Q
4 ;
S %=$$PATIENT^APCLV($P(^AMHRPROV(Y,0),U,3),"E")
Q
5 ;
S %=$P(^AMHRPROV(Y,0),U)
Q
6 D T Q
7 D A Q
8 D B Q
9 D C Q
10 D D Q
11 D E Q
12 D F Q
13 D N Q
14 D O Q
15 D P Q
16 S %=$P(^AMHRPROV(Y,0),U,4) Q
17 S %=$$VAL^XBDIQ1(9002011.02,Y,.04) Q
18 S %=$$VALI^XBDIQ1(9002011.02,Y,.05) Q
19 S %=$$VAL^XBDIQ1(9002011.02,Y,.05) Q
20 S %=$$VAL^XBDIQ1(9002011.02,Y,1201) Q
;
AMHUTIL ; IHS/CMI/LAB - UTILITIES ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**4**;JUN 18, 2010;Build 28
+2 ;
GUIPL(P,R,Z) ;EP - called from GUI for patient lookup
+1 IF '$GET(P)
QUIT 0
+2 IF '$GET(R)
SET R=$GET(DUZ)
+3 IF '$GET(R)
QUIT 0
+4 IF '$GET(Z)
SET Z=DUZ(2)
+5 IF '$GET(Z)
QUIT 0
+6 ;first check to see if patient has a HRN at DUZ(2) and it is not inactive, if they don't then quit cause we're done,
+7 ;they should log in to the site they want the patient from
+8 IF '$DATA(^AUPNPAT(P,41,Z,0))
QUIT 0
+9 IF $PIECE($GET(^AUPNPAT(P,41,Z,0)),U,2)=""
QUIT 0
+10 IF $PIECE(^AUPNPAT(P,41,Z,0),U,3)
QUIT 0
+11 ;now do the UU junk
+12 QUIT $$ALLOWP(R,P)
+13 ;
DV4() ;EP
+1 ;get date version 4.0 installed
+2 NEW X,Y
+3 SET X=$ORDER(^DIC(9.4,"C","AMH",0))
+4 IF X=""
QUIT ""
+5 SET Y=$ORDER(^DIC(9.4,X,22,"B","4.0",0))
+6 IF Y=""
QUIT ""
+7 QUIT $PIECE($GET(^DIC(9.4,X,22,Y,0)),U,3)
+8 ;
SSN(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$DATA(^DPT(P,0))
QUIT ""
+3 QUIT $SELECT($LENGTH($PIECE(^DPT(P,0),U,9))=9:$JUSTIFY("XXX-XX-"_$EXTRACT($PIECE(^DPT(P,0),U,9),6,9),11),1:$JUSTIFY($PIECE(^DPT(P,0),U,9),11))
+4 ;
ALLOWVI(P,V) ;EP - is user P allowed to see VISIT V
+1 ;P - DUZ, user internal entry number
+2 IF '$GET(P)
QUIT 0
+3 IF '$GET(V)
QUIT 0
+4 ;user is not in BH User file so allow
IF '$DATA(^AMHBHUSR(P,0))
QUIT $$ALLOWSDE(P,V)
+5 ; access to all visits
+6 ;no locations so allow all
IF '$ORDER(^AMHBHUSR(P,11,0))
QUIT $$ALLOWSDE(P,V)
+7 NEW R
+8 ;get location of encounter
SET R=$PIECE($GET(^AMHREC(V,0)),U,4)
+9 ;if no location, don't allow
IF 'R
QUIT $$ALLOWSDE(P,V)
+10 ;if location R is in the list of allowed
IF $DATA(^AMHBHUSR(P,11,R))
QUIT $$ALLOWSDE(P,V)
+11 ; locations then allow this visit to be seen by this user
+12 QUIT 0
ALLOWSDE(P,R) ;EP - is user allowed to see this visit based on "SDE" logic
+1 IF '$GET(P)
QUIT ""
+2 ;allow all with access
IF $DATA(^AMHSITE(DUZ(2),16,P))
QUIT 1
+3 NEW X,G,Z
SET G=0
SET X=0
FOR
SET X=$ORDER(^AMHRPROV("AD",R,X))
IF X'=+X
QUIT
IF $PIECE(^AMHRPROV(X,0),U)=P
SET G=1
+4 IF G
QUIT 1
+5 IF $PIECE(^AMHREC(R,0),U,19)=P
QUIT 1
+6 SET G=0
+7 SET X=0
FOR
SET X=$ORDER(^AMHREC(R,54,"B",X))
IF X'=+X
QUIT
Begin DoDot:1
+8 SET Z=$PIECE($GET(^TIU(8925,X,12)),U,2)
IF Z=P
SET G=1
End DoDot:1
+9 IF G
QUIT 1
+10 QUIT 0
+11 ;
ALLOWPCC(P,V) ;EP - is user P allowed to see VISIT V
+1 IF '$GET(P)
QUIT 0
+2 IF '$GET(V)
QUIT 0
+3 ;user is not in BH User file so allow
IF '$DATA(^AMHBHUSR(P,0))
QUIT $$PCCSDE(P,V)
+4 ; access to all visits
+5 ;no locations so allow all
IF '$ORDER(^AMHBHUSR(P,11,0))
QUIT $$PCCSDE(P,V)
+6 NEW R
+7 ;get location of encounter
SET R=$PIECE($GET(^AUPNVSIT(V,0)),U,6)
+8 ;if no location, don't allow
IF 'R
QUIT $$ALLOWSDE(P,V)
+9 ;if location R is in the list of allowed
IF $DATA(^AMHBHUSR(P,11,R))
QUIT $$PCCSDE(P,V)
+10 ; locations then allow this visit to be seen by this user
+11 ;check patient on the visit?
+12 NEW S
SET S=$PIECE(^AUPNVSIT(V,0),U,5)
+13 IF S
IF '$$ALLOWP(P,S)
QUIT 0
+14 ;otherwise, don't allow them to see it
QUIT $$PCCSDE(P,V)
+15 ;
PCCSDE(P,R) ;EP - is user allowed to see this visit based on "SDE" logic
+1 IF '$GET(P)
QUIT ""
+2 ;allow all with access
IF $DATA(^AMHSITE(DUZ(2),16,P))
QUIT 1
+3 NEW X,G
SET G=0
SET X=0
FOR
SET X=$ORDER(^AUPNVPRV("AD",R,X))
IF X'=+X
QUIT
IF $PIECE(^AUPNVPRV(X,0),U)=P
SET G=1
+4 IF G
QUIT 1
+5 IF $PIECE(^AUPNVSIT(R,0),U,23)=P
QUIT 1
+6 QUIT 0
+7 ;
ALLOWV(P,R) ;EP - is user P allowed to see a visit from location R
+1 ;P - DUZ, user internal entry number R - ien of location from file 9999999.06
+2 ;user is not in BH User file so allow
IF '$DATA(^AMHBHUSR(P,0))
QUIT 1
+3 ; access to all visits
+4 ;no locations so allow all
IF '$ORDER(^AMHBHUSR(P,11,0))
QUIT 1
+5 ;no valid location passed in so don't allow visit
IF 'R
QUIT 0
+6 ;if location R is in the list of allowed
IF $DATA(^AMHBHUSR(P,11,R))
QUIT 1
+7 ; locations then allow this visit to be seen
+8 QUIT 0
+9 ;
ALLOWP(P,R) ;EP - is user P allowed to see patient R?
+1 ;user is not in BH User file so allow
IF '$DATA(^AMHBHUSR(P,0))
QUIT 1
+2 ; access to all patients
+3 ;no valid location passed in so don't allow
IF 'R
QUIT 0
+4 ; access to this patient
+5 ;no locations so allow all
IF '$ORDER(^AMHBHUSR(P,11,0))
QUIT 1
+6 NEW G,X
SET G=0
+7 ;has a hrn
SET X=0
FOR
SET X=$ORDER(^AMHBHUSR(P,11,X))
IF X'=+X
QUIT
IF $DATA(^AUPNPAT(R,41,X))
SET G=1
+8 ;if patient has HRN at facility any facility in the BH USer file
IF G
QUIT 1
+9 ; then allow access to this patient
+10 QUIT 0
+11 ;
EHR(R) ;EP - called to determine if this is an EHR created visit
+1 IF '$GET(R)
QUIT ""
+2 QUIT $PIECE($GET(^AMHREC(R,11)),U,10)
+3 ;
NALLOWP ;EP - called to write a notification to the user
+1 DO EN^DDIOL("***** You do not have access to that patient's record, see your supervisor.","","!!")
+2 QUIT
+3 ;
DBHUSR ;EP - note to user
+1 IF '$DATA(^AMHBHUSR(DUZ,0))
QUIT
+2 IF '$ORDER(^AMHBHUSR(DUZ,11,0))
QUIT
+3 NEW X
+4 SET X=$GET(IORVON)_"Please note:"_$GET(IORVOFF)_" Only visits to the following locations will"
+5 DO EN^DDIOL(X,,"!!")
+6 DO EN^DDIOL("be displayed:",,"!?14")
+7 SET X=0
FOR
SET X=$ORDER(^AMHBHUSR(DUZ,11,X))
IF X'=+X
QUIT
DO EN^DDIOL($PIECE(^DIC(4,X,0),U),,"!?15")
+8 DO EN^DDIOL("",,"!!")
+9 QUIT
DBHUSRP ;EP - note to user
+1 IF '$DATA(^AMHBHUSR(DUZ,0))
QUIT
+2 IF '$ORDER(^AMHBHUSR(DUZ,11,0))
QUIT
+3 NEW X
+4 SET X=$GET(IORVON)_"Please note:"_$GET(IORVOFF)_" Only patients who have HRN's at the following "
+5 DO EN^DDIOL(X,,"!")
+6 DO EN^DDIOL("locations will be included in this report:",,"!?14")
+7 SET X=0
FOR
SET X=$ORDER(^AMHBHUSR(DUZ,11,X))
IF X'=+X
QUIT
DO EN^DDIOL($PIECE(^DIC(4,X,0),U),,"!?15")
+8 DO EN^DDIOL("",,"!")
+9 QUIT
ACTPROV(Y) ;EP called from data dictionary
+1 NEW D
SET D=""
+2 ;not a provider - no provider key
IF '$DATA(^VA(200,"AK.PROVIDER",$PIECE(^VA(200,Y,0),U),Y))
QUIT 0
+3 SET D=$SELECT($GET(AMHDATE)]"":$PIECE(AMHDATE,"."),1:"")
+4 IF D=""
IF $GET(DA)
IF $PIECE($GET(^AMHRPROV(DA,0)),U,3)]""
SET D=$PIECE($PIECE(^AMHREC($PIECE(^AMHRPROV(DA,0),U,3),0),U),".")
+5 IF $PIECE($GET(^VA(200,Y,"PS")),U,4)]""
IF $PIECE($GET(^VA(200,Y,"PS")),U,4)<D
QUIT 0
+6 QUIT 1
XTMP(N,D) ;EP -set xtmp( 0 node
+1 IF $GET(N)=""
QUIT
+2 SET ^XTMP(N,0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_$GET(D)
+3 QUIT
PPINI(AMHUREC) ;EP Retrieve BH Primary Provider Initials
+1 NEW X,Y,AMHX,AMHY,DIQ,DR,DA,AMHG,AMHINI,AMHGR
+2 SET AMHG="^AMHRPROV("
+3 SET AMHX=0
SET AMHGR=AMHG_"""AD"",AMHUREC,AMHX)"
FOR
SET AMHX=$ORDER(@AMHGR)
IF AMHX'=+AMHX
QUIT
IF $PIECE(@(AMHG_AMHX_",0)"),U,4)="P"
SET AMHY=$PIECE(^(0),U)
+4 IF '$DATA(AMHY)
SET AMHINI="???"
QUIT AMHINI
+5 SET AMHINI=$$VAL^XBDIQ1(200,AMHY,1)
+6 IF AMHINI=""
SET AMHINI="???"
+7 QUIT AMHINI
PPNAME(AMHUREC) ;EP
+1 NEW X,Y,AMHX,AMHY,DIQ,DR,DA,AMHG,AMHNAME,AMHGR
+2 SET AMHG="^AMHRPROV("
+3 SET AMHX=0
SET AMHGR=AMHG_"""AD"",AMHUREC,AMHX)"
FOR
SET AMHX=$ORDER(@AMHGR)
IF AMHX'=+AMHX
QUIT
IF $PIECE(@(AMHG_AMHX_",0)"),U,4)="P"
SET AMHY=$PIECE(^(0),U)
+4 IF '$DATA(AMHY)
SET AMHNAME="???"
QUIT AMHNAME
+5 SET AMHNAME=$PIECE(^VA(200,AMHY,0),U)
+6 IF AMHNAME=""
SET AMHNAME="???"
+7 QUIT AMHNAME
PPINT(R) ;EP primary provider internal # from 200
+1 NEW %,%1
+2 SET %=0
SET %1=""
FOR
SET %=$ORDER(^AMHRPROV("AD",R,%))
IF %'=+%
QUIT
IF $PIECE(^AMHRPROV(%,0),U,4)="P"
SET %1=$PIECE(^AMHRPROV(%,0),U)
+3 QUIT %1
PPAFFL(AMHUREC,AMHFORM) ;EP - get pp affiliation internal or external
+1 NEW X,Y,AMHX,AMHY,DIQ,DR,DA,AMHG,AMHAFFL,AMHGR
+2 SET AMHG="^AMHRPROV("
+3 SET AMHX=0
SET AMHGR=AMHG_"""AD"",AMHUREC,AMHX)"
FOR
SET AMHX=$ORDER(@AMHGR)
IF AMHX'=+AMHX
QUIT
IF $PIECE(@(AMHG_AMHX_",0)"),U,4)="P"
SET AMHY=$PIECE(^(0),U)
+4 IF '$DATA(AMHY)
SET AMHAFFL="?"
QUIT AMHAFFL
+5 SET DA=AMHY
SET DIC=200
SET DR=9999999.01
SET DIQ="AMHAFFL"
IF $GET(AMHFORM)="I"
SET DIQ(0)="I"
+6 DO EN^DIQ1
+7 SET AMHAFFL=$SELECT($GET(AMHFORM)="I":AMHAFFL(200,AMHY,9999999.01,"I"),1:AMHAFFL(200,AMHY,"9999999.01"))
+8 IF AMHAFFL=""
SET AMHAFFL="?"
+9 QUIT AMHAFFL
PPCLS(AMHUREC,AMHFORM) ;EP GET primary provider discipline
+1 NEW X,Y,AMHX,AMHY,DIQ,DR,DA,AMHG,AMHCLS,AMHGR
+2 SET AMHG="^AMHRPROV("
+3 SET AMHX=0
SET AMHGR=AMHG_"""AD"",AMHUREC,AMHX)"
FOR
SET AMHX=$ORDER(@AMHGR)
IF AMHX'=+AMHX
QUIT
IF $PIECE(@(AMHG_AMHX_",0)"),U,4)="P"
SET AMHY=$PIECE(^(0),U)
+4 IF '$DATA(AMHY)
SET AMHCLS="??"
QUIT AMHCLS
+5 SET DA=AMHY
SET DIC=200
SET DR=53.5
SET DIQ="AMHCLS"
IF $GET(AMHFORM)="I"
SET DIQ(0)="I"
+6 DO EN^DIQ1
+7 SET AMHCLS=$SELECT($GET(AMHFORM)="I":$GET(AMHCLS(200,AMHY,53.5,"I")),1:$GET(AMHCLS(200,AMHY,"53.5")))
+8 IF AMHCLS=""
SET AMHCLS="??"
+9 QUIT AMHCLS
PPCLSC(AMHUREC) ;EP GET PRIMARY PROVIDER CLASS CODE
+1 NEW X,Y,AMHCODE,DIC,DR,DA,DIQ,AMHCLS
+2 SET AMHCLS=$$PPCLS^AMHUTIL(AMHUREC,"I")
+3 IF AMHCLS="??"
SET AMHCODE="??"
QUIT AMHCODE
+4 SET DIC=7
SET DR="9999999.01"
SET DA=AMHCLS
SET DIQ="AMHCODE"
+5 DO EN^DIQ1
+6 SET AMHCODE=AMHCODE(7,AMHCLS,"9999999.01")
+7 IF AMHCODE=""
SET AMHCODE="??"
+8 QUIT AMHCODE
+9 ;
IN ;EP - called from input transform on .32 field
+1 IF X=""
QUIT
+2 IF $EXTRACT(X)'="I"
QUIT
+3 NEW P
SET P=$PIECE(^AMHREC(DA,0),U,8)
+4 IF '$DATA(^AMHREC("AIN",P,"IN"))
QUIT
+5 IF $ORDER(^AMHREC("AIN",P,"IN",0))=DA
QUIT
+6 DO EN^DDIOL("This Patient Already has an Initial Intake Record.")
+7 KILL X
+8 QUIT
DIFF ;EP - called from screenman
+1 IF $GET(DA)=""
QUIT
+2 IF $$GET^DDSVAL(9002011.06,DA,.21)=$$GET^DDSVAL(9002011.06,DA,.22)
DO PUT^DDSVAL(9002011.06,DA,.23,"")
DO UNED^DDSUTL("DIFFERENCE REASON",3,1,1)
QUIT
+3 DO UNED^DDSUTL("DIFFERENCE REASON",3,1,0)
+4 QUIT
SMK(A) ;EP - called from screen
+1 IF '$DATA(^AUTTHF(A,0))
QUIT 0
+2 IF $PIECE(^AUTTHF(A,0),U,10)'="F"
QUIT 0
+3 NEW B
SET B=$ORDER(^AUTTHF("B","TOBACCO",0))
IF 'B
QUIT 0
+4 IF $PIECE(^AUTTHF(A,0),U,3)'=B
QUIT 0
+5 QUIT 1
+6 ;
STAGE(R) ;EP called from screenman
+1 IF '$GET(R)
QUIT ""
+2 NEW %,%1,%2,%3,V
+3 SET (%,%1,%2,%3)=0
+4 FOR %=.12:.01:.18
SET V=$$GET^DDSVAL(9002011.06,R,%)
IF V
SET %1=%1+V
SET %2=%2+1
+5 IF '%2
QUIT 0
+6 QUIT $JUSTIFY((%1/%2),3,1)
ICDN(CIM) ;EP
+1 IF $GET(CIM)=""
QUIT ""
+2 NEW X,Y,Z
+3 SET Z=$PIECE(^AMHPROB(CIM,0),U,5)
+4 IF Z=""
QUIT ""
+5 IF $TEXT(ICDDX^ICDEX)=""
SET X=+$$CODEN^ICDCODE(Z,80)
+6 IF $TEXT(ICDDX^ICDEX)]""
SET X=+$$CODEN^ICDEX(Z,80)
+7 IF 'X!(X=-1)
QUIT ""
+8 IF $TEXT(ICDDX^ICDEX)=""
SET Y=$EXTRACT($PIECE($$ICDDX^ICDCODE(X),U,4),1,25)
+9 IF $TEXT(ICDDX^ICDEX)]""
SET Y=$EXTRACT($PIECE($$ICDDX^ICDEX(X),U,4),1,25)
+10 QUIT Y
DATE(D) ;EP - return YYYYMMDD from internal fm format
+1 IF $GET(D)=""
QUIT ""
+2 QUIT ($EXTRACT(D,1,3)+1700)_$EXTRACT(D,4,7)
UIDV(REC) ;EP - generate unique ID for visit
+1 IF '$GET(REC)
QUIT REC
+2 NEW X
+3 SET X=$$GET1^DIQ(9999999.06,$PIECE(^AUTTSITE(1,0),U),.32)
+4 QUIT X_$$LZERO(REC,10)
+5 ;
LZERO(V,L) ;EP - 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
POSTDA ;EP - called from screeNMAN
+1 DO REQ^DDSUTL(14,2,1,$SELECT(X=1:1,X=2:1,X=4:1,1:0))
+2 DO REQ^DDSUTL(15,2,1,$SELECT(X=3:1,X=5:1,1:0))
+3 IF X=1!(X=2)!(X=4)
DO PUT^DDSVAL(DIE,.DA,.17,"",,"I")
+4 IF X=3!(X=5)
DO PUT^DDSVAL(DIE,.DA,.16,"",,"I")
+5 QUIT
CHART(V) ;EP - returns ASUFAC_HRN
+1 NEW L,%,C,S,P,Z
+2 SET %=""
+3 IF '$DATA(^AMHREC(V,0))
QUIT %
+4 SET Z=^AMHREC(V,0)
+5 SET P=$PIECE(Z,U,8)
+6 IF 'P
QUIT %
+7 IF $PIECE(Z,U,4)
IF $DATA(^AUPNPAT(P,41,$PIECE(Z,U,4),0))
SET L=$PIECE(Z,U,4)
SET %=$$GETCHART(L)
IF %]""
QUIT %
+8 IF $GET(DUZ(2))
SET L=DUZ(2)
SET %=$$GETCHART(L)
+9 IF %=""
SET L=$ORDER(^AUPNPAT(P,41,0))
IF L
SET %=$$GETCHART(L)
+10 IF %=""
SET %=" ??????"
+11 QUIT %
GETCHART(L) ;
+1 SET S=$PIECE(^AUTTLOC(L,0),U,10)
+2 IF S=""
QUIT S
+3 SET C=$PIECE($GET(^AUPNPAT(P,41,L,0)),U,2)
+4 IF C=""
QUIT C
+5 SET C=$EXTRACT("000000",1,6-$LENGTH(C))_C
+6 SET %=S_C
+7 QUIT %
+8 ;
PRIMPROV(V,F) ;EP - primary provider in many different formats
+1 IF 'V
QUIT ""
+2 IF '$DATA(^AMHREC(V))
QUIT ""
+3 NEW %,Y,P,Z
+4 SET P=""
SET Y=0
FOR
SET Y=$ORDER(^AMHRPROV("AD",V,Y))
IF Y'=+Y
QUIT
IF $PIECE(^AMHRPROV(Y,0),U,4)="P"
SET P=$PIECE(^AMHRPROV(Y,0),U)
SET Z=Y
+5 IF 'P
QUIT P
+6 IF '$DATA(^VA(200,P))
QUIT ""
+7 IF $GET(F)=""
SET F="N"
+8 SET %=""
DO @F
+9 QUIT %
+10 ;
SECPROV(V,N,F) ;EP
+1 IF 'V
QUIT ""
+2 IF '$DATA(^AUPNVSIT(V))
QUIT ""
+3 IF '$GET(N)
QUIT ""
+4 NEW %,Y,P,Z
+5 SET P=""
SET (C,Y)=0
FOR
SET Y=$ORDER(^AMHRPROV("AD",V,Y))
IF Y'=+Y
QUIT
IF $PIECE(^AMHRPROV(Y,0),U,4)'="P"
SET C=C+1
IF C=N
SET P=$PIECE(^AMHRPROV(Y,0),U)
SET Z=Y
+6 IF 'P
QUIT P
+7 IF '$DATA(^VA(200,P))
QUIT ""
+8 IF $GET(F)=""
SET F="N"
+9 SET %=""
DO @F
+10 QUIT %
+11 ;
PROV ;EP
+1 NEW Z,C,%,S
+2 SET (C,Y)=0
FOR
SET Y=$ORDER(^AMHRPROV("AD",V,Y))
IF Y'=+Y
QUIT
SET C=C+1
SET APCLV(C)=""
SET P=$PIECE(^AMHRPROV(Y,0),U)
Begin DoDot:1
+3 IF F=99
Begin DoDot:2
+4 FOR I=1:1
SET S=$TEXT(@I)
IF S=""
QUIT
SET %=""
DO @I
SET $PIECE(APCLV(C),U,I)=%
End DoDot:2
QUIT
+5 IF F[";"
Begin DoDot:2
+6 FOR J=1:1
SET I=$PIECE(F,";",J)
IF I=""
QUIT
IF I'=99
SET %=""
DO @I
SET $PIECE(APCLV(C),U,J)=%
End DoDot:2
QUIT
+7 SET %=""
SET I=F
DO @I
SET $PIECE(APCLV(C),U)=%
+8 QUIT
End DoDot:1
+9 QUIT
METHOD(SFIEN) ;EP - called from export
+1 IF '$GET(SFIEN)
QUIT ""
+2 NEW X,Y,Z,C,D,A,B
+3 SET C=0
SET D=0
+4 SET X=0
SET Y=""
FOR
SET X=$ORDER(^AMHPSUIC(SFIEN,11,X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET C=C+1
+6 IF C=1
SET $PIECE(Y,U)=$PIECE(^AMHPSUIC(SFIEN,11,X,0),U)
+7 IF C=2
SET $PIECE(Y,U,2)=$PIECE(^AMHPSUIC(SFIEN,11,X,0),U)
+8 IF $PIECE(^AMHPSUIC(SFIEN,11,X,0),U)=8
IF $PIECE(^AMHPSUIC(SFIEN,11,X,0),U,2)]""
SET $PIECE(Y,U,3)=$SELECT($PIECE(Y,U,3)]"":" ",1:"")
SET $PIECE(Y,U,3)=$PIECE(Y,U,3)_$PIECE(^AMHPSUIC(SFIEN,11,X,0),U,2)
+9 IF $PIECE(^AMHPSUIC(SFIEN,11,X,0),U)=7
Begin DoDot:2
+10 SET A=0
FOR
SET A=$ORDER(^AMHPSUIC(SFIEN,11,X,11,A))
IF A'=+A
QUIT
Begin DoDot:3
+11 SET D=D+1
IF D>2
QUIT
SET P=D+3
SET Z=$PIECE(^AMHPSUIC(SFIEN,11,X,11,A,0),U,1)
IF Z
SET Z=$PIECE(^AMHTSDRG(Z,0),U)
SET $PIECE(Y,U,P)=Z
End DoDot:3
End DoDot:2
+12 QUIT
End DoDot:1
+13 QUIT Y
SUB(SFIEN) ;EP
+1 IF '$GET(SFIEN)
QUIT ""
+2 NEW X,Y,Z,C,D,J
+3 SET C=0
SET D=2
SET E=0
+4 SET $PIECE(Y,U)=$PIECE(^AMHPSUIC(SFIEN,0),U,26)
+5 SET J=0
SET E=0
FOR
SET J=$ORDER(^AMHPSUIC(SFIEN,15,J))
IF J'=+J
QUIT
Begin DoDot:1
+6 SET E=E+1
IF E>2
QUIT
SET Z=$PIECE(^AMHPSUIC(SFIEN,15,J,0),U)
IF Z
SET Z=$PIECE(^AMHTSSU(Z,0),U)
SET D=D+1
SET $PIECE(Y,U,D)=Z
+7 QUIT
End DoDot:1
+8 QUIT Y
CONTRIB(SFIEN) ;EP
+1 IF '$GET(SFIEN)
QUIT ""
+2 NEW X,Y,Z,C
+3 SET C=0
SET X=0
SET Y=""
FOR
SET X=$ORDER(^AMHPSUIC(SFIEN,13,X))
IF X'=+X
QUIT
Begin DoDot:1
+4 SET C=C+1
SET Z=$PIECE(^AMHPSUIC(SFIEN,13,X,0),U)
IF Z
SET Z=$PIECE(^AMHTSCF(Z,0),U)
SET $PIECE(Y,U,C)=Z
+5 QUIT
End DoDot:1
+6 QUIT Y
REFCHK ;EP - called from screenman to check placement disp and referred to
+1 NEW A,B
+2 SET A=$$GET^DDSVAL(DIE,DA,.17)
+3 SET B=$$GET^DDSVAL(DIE,DA,.18)
+4 IF A]""
IF B=""
DO EN^DDIOL("If Placement Disposition is entered, Referred to is Required.")
SET DDSBR="1^1^2.2"
QUIT
+5 IF A=""
IF B]""
DO EN^DDIOL("If Referred to is entered, Placement Disposition is Required.")
SET DDSBR="19^2^1"
QUIT
+6 QUIT
REFED ;EP - called from screenman to check placement disp and referred to
+1 NEW A,B
+2 SET A=$$GET^DDSVAL(DIE,DA,.17)
+3 SET B=$$GET^DDSVAL(DIE,DA,.18)
+4 IF A]""
IF B=""
DO EN^DDIOL("If Placement Disposition is entered, Referred to is Required.")
SET DDSBR="1^1^2.2"
QUIT
+5 IF A=""
IF B]""
DO EN^DDIOL("If Referred to is entered, Placement Disposition is Required.")
SET DDSBR="29^2^1"
QUIT
+6 QUIT
LISTAT ;EP - called from executable help from activity type
+1 NEW A,B,C
+2 SET A=0
FOR
SET A=$ORDER(^AMHTACT("AC",A))
IF A=""
QUIT
Begin DoDot:1
+3 SET B=0
FOR
SET B=$ORDER(^AMHTACT("AC",A,B))
IF B'=+B
QUIT
Begin DoDot:2
+4 DO EN^DDIOL($PIECE(^AMHTACT(B,0),U,1)_" "_$PIECE(^AMHTACT(B,0),U,2),"","!")
End DoDot:2
+5 QUIT
End DoDot:1
+6 QUIT
SETBAA ;EP
+1 IF '$DATA(X)
QUIT
+2 IF $LENGTH($PIECE(X,".",1))<3
SET ^AMHPROB("BAA",X,DA)=""
QUIT
+3 IF $EXTRACT(X)="0"
SET ^AMHPROB("BAA",X,DA)=""
QUIT
+4 IF $EXTRACT(X)="V"
SET ^AMHPROB("BAA",X,DA)=""
QUIT
+5 SET ^AMHPROB("BAA",$$RBLK^AMHLEDV(X,7),DA)=""
QUIT
+6 QUIT
KILLBAA ;EP
+1 IF '$DATA(X)
QUIT
+2 IF $LENGTH($PIECE(X,".",1))<3
KILL ^AMHPROB("BAA",X,DA)
QUIT
+3 IF $EXTRACT(X)="0"
KILL ^AMHPROB("BAA",X,DA)
QUIT
+4 IF $EXTRACT(X)="V"
KILL ^AMHPROB("BAA",X,DA)
QUIT
+5 KILL ^AMHPROB("BAA",$$RBLK^AMHLEDV(X,7),DA)
QUIT
+6 QUIT
+7 ;
I ;EP
+1 SET %=P
QUIT
T ;EP
+1 SET %=$PIECE($GET(^VA(200,P,0)),U,2)
QUIT
A ;EP
+1 SET %=$PIECE($GET(^VA(200,P,9999999)),U)
QUIT
B ;EP
+1 SET %=$PIECE($GET(^VA(200,P,9999999)),U)
+2 IF %=""
QUIT
+3 SET %=$$EXTSET^XBFUNC(200,9999999.01,%)
+4 QUIT
D ;EP
+1 DO F
+2 IF %=""
QUIT
+3 SET %=$PIECE($GET(^DIC(7,%,9999999)),U)
+4 QUIT
+5 ;
E ;EP
+1 SET %=$$VAL^XBDIQ1(200,P,53.5)
+2 QUIT
F ;EP
+1 SET %=$$VALI^XBDIQ1(200,P,53.5)
+2 QUIT
C ;EP
+1 SET %=$PIECE($GET(^VA(200,P,9999999)),U,2)
QUIT
N ;EP
+1 SET %=$PIECE($GET(^VA(200,P,0)),U)
QUIT
O ;EP
+1 NEW A
DO A
IF %=""
QUIT
SET A=%
SET %=""
DO D
IF %=""
QUIT
SET %=A_%
QUIT
P ;EP
+1 NEW A
DO A
IF %=""
QUIT
SET A=%
NEW D
DO D
IF %=""
QUIT
SET D=%
SET %=""
DO C
IF %=""
QUIT
SET %=A_D_%
QUIT
1 ;
+1 SET %=$$VD^APCLV($PIECE(^AMHRPROV(Y,0),U,3),"I")
+2 QUIT
2 ;
+1 SET %=$$VD^APCLV($PIECE(^AMHRPROV(Y,0),U,3),"S")
+2 QUIT
3 ;
+1 SET %=$PIECE(^AMHRPROV(Y,0),U,2)
+2 QUIT
4 ;
+1 SET %=$$PATIENT^APCLV($PIECE(^AMHRPROV(Y,0),U,3),"E")
+2 QUIT
5 ;
+1 SET %=$PIECE(^AMHRPROV(Y,0),U)
+2 QUIT
6 DO T
QUIT
7 DO A
QUIT
8 DO B
QUIT
9 DO C
QUIT
10 DO D
QUIT
11 DO E
QUIT
12 DO F
QUIT
13 DO N
QUIT
14 DO O
QUIT
15 DO P
QUIT
16 SET %=$PIECE(^AMHRPROV(Y,0),U,4)
QUIT
17 SET %=$$VAL^XBDIQ1(9002011.02,Y,.04)
QUIT
18 SET %=$$VALI^XBDIQ1(9002011.02,Y,.05)
QUIT
19 SET %=$$VAL^XBDIQ1(9002011.02,Y,.05)
QUIT
20 SET %=$$VAL^XBDIQ1(9002011.02,Y,1201)
QUIT
+1 ;
