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

AMHUTIL3.m

Go to the documentation of this file. 
  1. AMHUTIL3 ; IHS/CMI/LAB - provider functions ;
  1.  ;;4.0;IHS BEHAVIORAL HEALTH;**2,3,4,6**;JUN 02, 2010;Build 10
  1.  ;IHS/CMI/LAB - added stage as output parameter
  1.  ;
  1.  ;IHS/TUCSON/LAB - patch 1 05/19/97 - fixed setting of array
  1. RACESF(PAT) ;
  1.  NEW Y,Z,X,I
  1.  K Z
  1.  S X=""
  1.  D LIST^DIC(2.02,","_PAT_",","@;.01E","P",,,,,,,"Z")
  1.  S Y=0 F  S Y=$O(Z("DILIST",Y)) Q:Y=""  D
  1.  .S I=$P($G(^DIC(10,+$P(Z("DILIST",Y,0),U,1),.02)),U,1)
  1.  .Q:I
  1.  .S Z=$P(^DIC(10,+$P(Z("DILIST",Y,0),U,1),0),U,3)
  1.  .;I Z="" S Z=$P(^DIC(10,+$P(Z("DILIST",Y,0),U,1),0),U,2)
  1.  .Q:Z=""
  1.  .S X=X_Z_U
  1.  Q X
  1. ETHN(P) ;EP
  1.  I '$G(P) Q ""
  1.  I $G(F)="" S F="E"
  1.  I '$D(^DPT(P,0)) Q ""
  1.  NEW Z,E,I
  1.  S (E,I)=""
  1.  S Z=0 F  S Z=$O(^DPT(P,.06,Z)) Q:Z'=+Z!(E]"")  D
  1.  .S I=$P($G(^DPT(P,.06,Z,0)),U,1)
  1.  .Q:I=""
  1.  .S E=$P($G(^DIC(10.2,I,0)),U,2)
  1.  .Q
  1.  Q E
  1. ASUFACLD(R) ;EP - get asufac of logged in facility suicide form
  1.  I '$G(R) Q ""
  1.  I '$D(^AMHPSUIC(R,0)) Q ""
  1.  NEW Z
  1.  S Z=$$VALI^XBDIQ1(9002011.65,R,.28)
  1.  I 'Z Q ""
  1.  Q $$VAL^XBDIQ1(9999999.06,Z,.12)
  1. DLM(V) ;EP date last modified
  1.  I 'V Q ""
  1.  I '$D(^AMHREC(V)) Q ""
  1.  NEW R
  1.  S R=""
  1.  S R=$S($P($G(^AMHREC(V,11)),U,14)]"":$$DATE^AMHUTIL($P(^AMHREC(V,11),U,14)),1:$$DATE^AMHUTIL($P(^AMHREC(V,0),U,21)))
  1.  Q R
  1. TLM(V) ;EP
  1.  NEW R
  1.  S R=$P($G(^AMHREC(V,11)),U,14)
  1.  I R="" Q ""
  1.  S R=$$FMTE^XLFDT(R,"2P")
  1.  Q $$UP^XLFSTR($P($P(R," ",2),":",1,2))_$$UP^XLFSTR($P(R," ",3))
  1.  ;
  1. UID(P) ;EP
  1.  I '$D(^AUPNPAT(P,0)) Q ""
  1.  I '$L($T(UID^BDWAID)) G UIDO
  1.  S X=$$UID^BDWAID(P) Q X
  1. UIDO ;
  1.  Q $$GET1^DIQ(9999999.06,$P(^AUTTSITE(1,0),U),.32)_$E("0000000000",1,10-$L(P))_P
  1.  ;
  1. VTIME(V) ;
  1.  NEW R
  1.  S R=$P($G(^AMHREC(V,0)),U,1)
  1.  I R="" Q ""
  1.  S R=$$FMTE^XLFDT(R,"2P")
  1.  Q $$UP^XLFSTR($P($P(R," ",2),":",1,2))_$$UP^XLFSTR($P(R," ",3))
  1.  ;
  1. DLMSF(V) ;EP date last modified
  1.  I 'V Q ""
  1.  I '$D(^AMHPSUIC(V)) Q ""
  1.  NEW R
  1.  S R=""
  1.  S R=$S($P($G(^AMHPSUIC(V,0)),U,27)]"":$$DATE^AMHUTIL($P(^AMHPSUIC(V,0),U,27)),1:$$DATE^AMHUTIL($P(^AMHPSUIC(V,0),U,21)))
  1.  Q R
  1. TLMSF(V) ;
  1.  NEW R
  1.  S R=$P($G(^AMHPSUIC(V,0)),U,27)
  1.  I R="" Q ""
  1.  S R=$$FMTE^XLFDT(R,"2P")
  1.  Q $$UP^XLFSTR($P($P(R," ",2),":",1,2))_$$UP^XLFSTR($P(R," ",3))
  1.  ;
  1. MSR6(V) ;EP - return first 6 measurements and values
  1.  I 'V Q ""
  1.  I '$D(^AMHREC(V)) Q ""
  1.  NEW Y,R,C,F,S
  1.  S R="",(Y,C)=0,F=1,S=2
  1.  F  S Y=$O(^AMHRMSR("AD",V,Y)) Q:Y'=+Y!(C>5)  S C=C+1,$P(R,U,F)=$$VAL^XBDIQ1(9002011.12,Y,.01),$P(R,U,S)=$P(^AMHRMSR(Y,0),U,4) S F=F+2,S=S+2
  1.  Q R
  1. PED(V,N) ;EP - return nth v patient ed on this visit
  1.  I 'V Q ""
  1.  I '$D(^AMHREC(V)) Q ""
  1.  I '$G(N) Q ""
  1.  NEW %,Y,P,C,Z
  1.  S (Z,P)="",(Y,C)=0
  1.  S Y=0 F  S Y=$O(^AMHREDU("AD",V,Y)) Q:Y'=+Y   S C=C+1 I C=N S P=$P(^AMHREDU(Y,0),"^"),Z=Y
  1.  I 'P Q P
  1.  I '$D(^AUTTEDT(P)) Q ""
  1.  S R=$P(^AUTTEDT(P,0),U,2)
  1.  S %="" D  S R=R_U_%
  1.  .S P=$P(^AMHREDU(Z,0),U,4) I %="" Q
  1.  .NEW A D A^AMHUTIL Q:%=""  S A=% NEW D D D^AMHUTIL Q:%=""  S D=%,%="" D C^AMHUTIL1 Q:%=""  S %=A_D_% Q
  1.  S R=R_U_$P(^AMHREDU(Z,0),U,5)_U_$P(^AMHREDU(Z,0),U,6)_U_$$VAL^XBDIQ1(9002011.05,Z,.07)_U_$P(^AMHREDU(Z,0),U,8)_U_$$VAL^XBDIQ1(9002011.05,Z,1102)
  1.  Q R
  1.  ;
  1. HF(V,N) ;EP
  1.  I 'V Q ""
  1.  I '$D(^AMHREC(V)) Q ""
  1.  I '$G(N) Q ""
  1.  NEW %,Y,P,C,Z
  1.  S (Z,P)="",(Y,C)=0
  1.  S Y=0 F  S Y=$O(^AMHRHF("AD",V,Y)) Q:Y'=+Y   S C=C+1 I C=N S P=$P(^AMHRHF(Y,0),"^"),Z=Y
  1.  I 'P Q P
  1.  I '$D(^AUTTHF(P)) Q ""
  1.  S R=$P(^AUTTHF(P,0),U,1)
  1.  S %="" D  S R=R_U_%
  1.  .S P=$P(^AMHRHF(Z,0),U,5) I %="" Q
  1.  .NEW A D A^AMHUTIL Q:%=""  S A=% NEW D D D^AMHUTIL Q:%=""  S D=%,%="" D C^AMHUTIL1 Q:%=""  S %=A_D_% Q
  1.  S R=R_U_$P(^AMHRHF(Z,0),U,4)_U_$P(^AMHRHF(Z,0),U,6)
  1.  Q R
  1.  ;
  1. PRIMPA(V,F) ;EP - primary provider in many different formats
  1.  I 'V Q ""
  1.  I '$D(^AMHREC(V)) Q ""
  1.  NEW %,Y,P,C,Z
  1.  S (Z,P)="",(Y,C)=0
  1.  S Y=$O(^AMHRPA("AD",V,0)) I Y S P=$P(^AMHRPA(Y,0),U),Z=Y
  1.  I 'P Q P
  1.  I '$D(^AMHTPA(P)) Q ""
  1.  I $G(F)="" S F="C"
  1.  S %="" D @F
  1.  Q %
  1.  ;
  1. SECPA(V,N,F) ;EP
  1.  I 'V Q ""
  1.  I '$D(^AMHREC(V)) Q ""
  1.  I '$G(N) Q ""
  1.  NEW %,Y,P,C,Z
  1.  S (Z,P)="",(Y,C)=0
  1.  S Y=0,C=-1 F  S Y=$O(^AMHRPA("AD",V,Y)) Q:Y'=+Y   S C=C+1 I C=N S P=$P(^AMHRPA(Y,0),U),Z=Y
  1.  I 'P Q P
  1.  I '$D(^AMHTPA(P)) Q ""
  1.  I $G(F)="" S F="C"
  1.  S %="" D @F
  1.  Q %
  1.  ;
  1. PA ;EP
  1.  NEW Z,C,%,S,I,J
  1.  S (C,Y)=0 F  S Y=$O(^AMHRPA("AD",V,Y)) Q:Y'=+Y   S C=C+1 S APCLV(C)="",P=$P(^AMHRPA(Y,0),U),Z=Y 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,I)=% ;IHS/TUCSON/LAB - patch 1 05/19/97 changed ,I TO ,J
  1.  .S %="",I=F D @I S $P(APCLV(C),U)=%
  1.  .Q
  1.  Q
  1. ADMDX ;EP
  1.  I 'V Q ""
  1.  I '$D(^AMHREC(V)) Q ""
  1.  NEW %,Y,Z
  1.  S %="",Z=$O(^AUPNVINP("AD",V,0))
  1.  I 'Z Q %
  1.  S P=$P(^AUPNVINP(Z,0),U,12)
  1.  I 'P Q P
  1.  I '$D(^AMHTPA(P)) Q ""
  1.  I $G(F)="" S F="C"
  1.  S %="" D @F
  1.  Q %
  1.  ;
  1. OTHMETH ;EP - called from screenman
  1.  I $G(X)=$G(DDSOLD) Q  ;no change
  1.  I Y=-1 Q  ;no change
  1.  I X'=8 D PUT^DDSVAL(DIE,.DA,.02,"",,"I") Q
  1.  ;I X=8 D REQ^DDSUTL(2,1,1.4,1)
  1.  Q
  1. I ;
  1.  S %=P Q
  1. E ;
  1.  S %=$P(^AMHTPA(P,0),U,3) Q
  1. C ;
  1.  S %=$P(^AMHTPA(P,0),U,2) Q
  1. D ;
  1.  S %=$P(^AMHRPA(Z,0),U,7) Q
  1. J ;
  1.  S %=$P(^AMHRPA(Z,0),U,9) I % S %=$P(^AMHTPA(%,0),U) Q
  1.  Q
  1. P ;
  1.  S %=$P(^AMHRPA(Z,0),U,11) Q
  1. N ;
  1.  S %=$P(^AMHRPA(Z,0),U,4)
  1.  Q
  1. S ;stage
  1.  S %=$P(^AMHRPA(Z,0),U,5) Q
  1. A ;
  1.  NEW I,H,R,L,E,D
  1.  S I=$P(^AMHTPA(P,0),U)
  1.  I $E(I)="E" S %=999 Q
  1.  I $E(I)="." D CODE10 G HIGH
  1.  S R="09"_($P(I,".")_$P(I,".",2))_" "
  1.  I $E(I)="V" S I=9_$E(I,2,9999),I=I-.000001,I="09V"_$E(I,2,9999),I=$P(I,".")_$P(I,".",2)_" " G HIGH
  1.  S I="09"_I-.000001
  1.  S %="",I="0"_($P(I,".")_$P(I,".",2))_" "
  1. HIGH S H=$O(^AUTTRCD("AH",I)) I H="" S %=999 Q
  1.  S D=$O(^AUTTRCD("AH",H,"")) I D="" S %="" Q
  1.  S E=$O(^AUTTRCD("AH",H,D,""))
  1.  S L=$P(^AUTTRCD(D,11,E,0),U)_" "
  1.  I L]R S %=999 Q
  1.  S %=$P(^AUTTRCD(D,0),U)
  1.  Q
  1. CODE10 ;
  1.  S R="10"_$P(I,".",2)_" "
  1.  S I="10"_I,I=I-.000001,I=$P(I,".")_$P(I,".",2)_" "
  1.  Q
  1.  ;
  1. 1 ;
  1.  S %=$$VD^APCLV($P(^AMHRPA(Y,0),U,3),"I")
  1.  Q
  1. 2 ;
  1.  S %=$$VD^APCLV($P(^AMHRPA(Y,0),U,3),"S")
  1.  Q
  1. 3 ;
  1.  S %=$P(^AMHRPA(Y,0),U,2)
  1.  Q
  1. 4 ;
  1.  S %=$$PATIENT^APCLV($P(^AMHRPA(Y,0),U,3),"E")
  1.  Q
  1. 5 ;
  1.  S %=Y
  1.  Q
  1. 6 D E Q
  1. 7 D C Q
  1. 8 D A Q
  1. 9 D D Q
  1. 10 S %=$$VAL^XBDIQ1(9000010.07,Y,.07) Q
  1. 11 D J Q
  1. 12 D P Q
  1. 13 S %=$$VAL^XBDIQ1(9000010.07,Y,.11) Q
  1. 14 D N Q
  1. 15 S %=$P(^AMHRPA(Y,0),U,12) Q
  1. 16 S %=$$VAL^XBDIQ1(9000010.07,Y,.12) Q
  1. 17 S %=$$VAL^XBDIQ1(9000010.07,Y,.13) Q
  1. 18 S %=$$VAL^XBDIQ1(9000010.07,Y,.05) Q
  1. 19 S %=$$VALI^XBDIQ1(9000010.07,Y,.06) Q
  1. 20 S %=$$VAL^XBDIQ1(9000010.07,Y,.06) Q