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

AMHUTIL.m

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