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