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

AMHRLP3.m

Go to the documentation of this file.
  1. AMHRLP3 ; IHS/CMI/LAB - PROCESS RECORD ;
  1. ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
  1. ;
  1. FLAT ;EP -called from AMHRLP
  1. RECORD ;EP
  1. S AMHTX=""
  1. RECTYPE S X="A" D TX
  1. DATE S X=$P($P(AMHREC,U),".") I X="" S X=" "
  1. D TX
  1. DUZ2 S X=$P(^AUTTLOC(DUZ(2),0),U,10) I X=""!($L(X)'=6) S X=" "
  1. D TX S AMHDUZ2=X
  1. PROG S X=$P(AMHREC,U,2) I X="" S X="X"
  1. D TX
  1. LOENC S X=$P(AMHREC,U,4) I X="" Q
  1. S X=$P(^AUTTLOC(X,0),U,10) I X=""!($L(X)'=6) S X=" "
  1. D TX S AMHLOC=X
  1. COMM S AMHCOM=$P(AMHREC,U,5) I AMHCOM="" S AMHCOM=" " G COMMTX
  1. S X=$P(^AUTTCOM(AMHCOM,0),U,8) I X="" S X=" "
  1. I $L(X)'=7 S X=" "
  1. COMMTX D TX
  1. K AMHTMP,^UTILITY("DIQ1",$J) S DIC="^AUTTCOM(",DR=".11991;.11992",DA=AMHCOM,DIQ="AMHTMP(",DIQ(0)="E" D EN^DIQ1 K DIC,DR,DIQ,^UTILITY("DIQ1",$J)
  1. S X=$G(AMHTMP(9999999.05,AMHCOM,.11992,"E"))_$G(AMHTMP(9999999.05,AMHCOM,.11991,"E"))_$P(^AUTTCOM(AMHCOM,0),U,7)
  1. I $L(X)'=7 S X=" "
  1. D TX
  1. ACT S X=$P(AMHREC,U,6) I X="" Q
  1. I '$D(^AMHTACT(X)) Q
  1. S X=$P(^AMHTACT(X,0),U) I X="" Q
  1. D TX
  1. CONT S X=$P(AMHREC,U,7) I X="" Q
  1. I '$D(^AMHTSET(X)) Q
  1. S X=$P(^AMHTSET(X,0),U,2) I X="" Q
  1. D TX
  1. NS S X=$P(AMHREC,U,9) I 'X S X=0
  1. S X=$$LZERO(X,3)
  1. D TX
  1. MIN S X=$P(AMHREC,U,12) I 'X S X=0
  1. S X=$$LZERO(X,5)
  1. D TX
  1. DISP ;inpatient disposition
  1. S X=$P(AMHREC,U,17) S:X X=$P(^AMHTPLT(X,0),U,3) S:X=10 X=0 S:X>9 X="" S X=$$LBLK(X,1) ;GONE TO 2 DIGITS!! OLD VALUES SENT FOR NOW
  1. D TX
  1. APWI ;
  1. S X=$P(AMHREC,U,11) S X=$$LBLK(X,1)
  1. D TX
  1. INT ;
  1. S X=$P(AMHREC,U,15) S X=$$LBLK(X,1)
  1. D TX
  1. PROV ;get providers (1-4) addiii
  1. I '$D(^AMHRPROV("AD",AMHR)) S X="",X=$$LBLK(X,24) D TX G POVS
  1. S AMHAFF=$$PPAFFL^AMHUTIL(AMHR,"I")
  1. S AMHDISC=$$PPCLSC^AMHUTIL(AMHR) I AMHDISC=""!(AMHDISC["?") S AMHDISC="??"
  1. S AMHINI=$$PPINI^AMHUTIL(AMHR)
  1. S AMHINI=$$LBLK(AMHINI,3)
  1. PROV1 S X=AMHAFF_AMHDISC_AMHINI D TX
  1. S AMHRIEN=0,AMHC=1 F S AMHRIEN=$O(^AMHRPROV("AD",AMHR,AMHRIEN)) Q:AMHRIEN'=+AMHRIEN I $P(^AMHRPROV(AMHRIEN,0),U,4)'="P" S AMHX=$P(^AMHRPROV(AMHRIEN,0),U) D
  1. .S AMHAFF=$$PROVAFFL^XBFUNC1(AMHX,"I") I AMHAFF=""!(AMHAFF["?") S AMHAFF=" "
  1. .S AMHDISC=$$PROVCLSC^XBFUNC1(AMHX) I AMHDISC=""!(AMHDISC["?") S AMHDISC=" "
  1. .S AMHINI=$$PROVINI^XBFUNC1(AMHX)
  1. .S AMHINI=$$LBLK(AMHINI,3)
  1. .S X=AMHAFF_AMHDISC_AMHINI D TX
  1. .S AMHC=AMHC+1
  1. .Q
  1. F I=(AMHC+1):1:4 S X="",X=$$LBLK(X,6) D TX
  1. POVS ;get problems first 4
  1. I '$D(^AMHRPRO("AD",AMHR)) S X="",X=$$LBLK(X,24) D TX G PATIENT
  1. S (AMHRIEN,AMHC)=0 F S AMHRIEN=$O(^AMHRPRO("AD",AMHR,AMHRIEN)) Q:AMHRIEN'=+AMHRIEN S P=$P(^AMHRPRO(AMHRIEN,0),U),X=$P(^AMHPROB(P,0),U),X=$$LBLK(X,6),AMHC=AMHC+1 D TX
  1. F I=(AMHC+1):1:4 S X="",X=$$LBLK(X,6) D TX
  1. K AMHRIEN,P,X
  1. PATIENT ;
  1. I $P(AMHREC,U,8)="" S X="",X=$$LBLK(X,63) D TX Q
  1. S AMHPAT=$P(AMHREC,U,8)
  1. S Y=AMHPAT D ^AUPNPAT
  1. S AMHNAME=$P(^DPT(AMHPAT,0),U)
  1. CHART ;
  1. S X=$$ENC^AMHRLU2(AMHPAT)
  1. D TX
  1. SEX ;
  1. I AUPNSEX="" S AUPNSEX=" "
  1. S X=AUPNSEX D TX
  1. DOB ;
  1. I AUPNDOB="" S AUPNDOB=" "
  1. S X=AUPNDOB D TX
  1. I '$D(^AUPNPAT(AMHPAT,11)) S X=" " D TX G MCARE
  1. COMRES ;
  1. S Y=0,AMHCOM="" F S Y=$O(^AUPNPAT(AMHPAT,51,Y)) Q:Y'=+Y S AMHCOM=Y
  1. I AMHCOM="" S X=" " D TX G TRIBE
  1. S AMHCOM=$P(^AUPNPAT(AMHPAT,51,AMHCOM,0),U,3) I AMHCOM="" S X=" " D TX G TRIBE
  1. I '$D(^AUTTCOM(AMHCOM,0)) S X=" " D TX G TRIBE
  1. I AMHCOM]"" S X=$P(^AUTTCOM(AMHCOM,0),U,8) I X="" S X=" " D TX G TRIBE
  1. D TX
  1. ;GET ASUCOMM CODE HERE AND D TX
  1. K AMHTMP,^UTILITY("DIQ1",$J) S DIC="^AUTTCOM(",DR=".11991;.11992",DA=AMHCOM,DIQ="AMHTMP(",DIQ(0)="E" D EN^DIQ1 K DIC,DR,DIQ,^UTILITY("DIQ1",$J)
  1. S X=$G(AMHTMP(9999999.05,AMHCOM,.11992,"E"))_$G(AMHTMP(9999999.05,AMHCOM,.11991,"E"))_$P(^AUTTCOM(AMHCOM,0),U,7)
  1. I $L(X)'=7 S X=" "
  1. D TX
  1. TRIBE ;
  1. S X=$P(^AUPNPAT(AMHPAT,11),U,8) I X="" S X=" " D TX G MCARE
  1. I $P(^AUTTTRI(X,0),U,4)="Y" S X=" " D TX G MCARE
  1. S X=$P(^AUTTTRI(X,0),U,2) I X="" S X=" " G MCARE
  1. D TX
  1. MCARE ;
  1. S X=$$MCR^AMHRLU(AMHPAT,$P($P(AMHREC,U),"."))
  1. S X=$S(X:"Y",1:"N")
  1. D TX
  1. MCAID ;
  1. S X=$$MCD^AMHRLU(AMHPAT,$P($P(AMHREC,U),"."))
  1. S X=$S(X:"Y",1:"N")
  1. D TX
  1. PI ;
  1. S X=$$PI^AMHRLU(AMHPAT,$P($P(AMHREC,U),"."))
  1. S X=$S(X:"Y",1:"N")
  1. D TX
  1. Q
  1. ;
  1. TX ;
  1. S AMHTX=AMHTX_X
  1. Q
  1. ;
  1. LZERO(V,L) ;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. LBLK(V,L) ;left blank fill
  1. NEW %,I
  1. S %=$L(V),Z=L-% F I=1:1:Z S V=" "_V
  1. Q V