AMHEXD2 ; IHS/CMI/LAB - PROCESS RECORD ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;
;encryted patient id info, fixed sec prov to check for unknown
;
RECORD ;EP
S (AMHE,AMHTX)="" K AMHRTYPE
I '$D(^AMHREC(AMHR)) S AMHE="E026" Q
RECTYPE I AMHO("RUN")="NEW" S X=$P(AMHREC,U,22) I X="" S X=$S($P(AMHREC,U,24)]"":"M",1:"A")
I AMHO("RUN")="REDO" S X=$P(^AMHXLOG(AMH("RUN LOG"),21,AMHR,0),U,3) I X="" S X="A"
D TX
DATE S X=$P($P(AMHREC,U),".") I X="" S AMHE="E001" Q
D TX
DUZ2 S X=$P(^AUTTLOC(DUZ(2),0),U,10) I X=""!($L(X)'=6) S AMHE="E002" Q
D TX S AMHDUZ2=X
PROG S X=$P(AMHREC,U,2) I X="" S AMHE="E003" Q
D TX
LOENC S X=$P(AMHREC,U,4) I X="" S AMHE="E004" Q
S X=$P(^AUTTLOC(X,0),U,10) I X=""!($L(X)'=6) S AMHE="E005" Q
D TX S AMHLOC=X
COMM S AMHCOM=$P(AMHREC,U,5) I AMHCOM="" S AMHE="E006" Q
S X=$P(^AUTTCOM(AMHCOM,0),U,8) I X="" S AMHE="E007" Q
I $L(X)'=7 S AMHE="E007" Q
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="" S AMHE="E009" Q
I '$D(^AMHTACT(X)) S AMHE="E009" Q
S X=$P(^AMHTACT(X,0),U) I X="" S AMHE="E009" Q
D TX
CONT S X=$P(AMHREC,U,7) I X="" S AMHE="E010" Q
I '$D(^AMHTSET(X)) S AMHE="E010" Q
S X=$P(^AMHTSET(X,0),U,2) I X="" S AMHE="E010" Q
S:$L(X)=2 X=0
D TX
NS ;S X=$P(AMHREC,U,9) I 'X S AMHE="E011" Q
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 AMHE="E012" Q
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
I '$D(^AMHRPROV("AD",AMHR)) S AMHE="E022" Q
S AMHAFF=$$PPAFFL^AMHUTIL(AMHR,"I") I AMHAFF=""!(AMHAFF["?") S AMHE="E023" Q
S AMHDISC=$$PPCLSC^AMHUTIL(AMHR) I AMHDISC=""!(AMHDISC["?") S AMHE="E024" Q
S AMHINI=$$PPINI^AMHUTIL(AMHR) I AMHINI["?" S AMHE="E025" Q
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!(AMHE]"") 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 AMHE="E023" Q
.S AMHDISC=$$PROVCLSC^XBFUNC1(AMHX) I AMHDISC=""!(AMHDISC["?")!(AMHDISC["UNKNOWN") S AMHE="E024" Q
.S AMHINI=$$PROVINI^XBFUNC1(AMHX) I AMHINI=""!(AMHINI["?") S AMHE="E025" Q
.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
Q:AMHE]""
POVS ;get problems first 4
I '$D(^AMHRPRO("AD",AMHR)) S AMHE="E021" Q
S (AMHRIEN,AMHC)=0 F S AMHRIEN=$O(^AMHRPRO("AD",AMHR,AMHRIEN)) Q:AMHRIEN'=+AMHRIEN!(AMHC=4) 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=$$LBLK($P(AMHREC,U,8),40) D TX Q
S AMHPAT=$P(AMHREC,U,8)
S Y=AMHPAT D ^AUPNPAT
S AMHNAME=$P(^DPT(AMHPAT,0),U)
I AMHNAME="DEMO,PATIENT" S X="",X=$$LBLK(X,40) D TX Q
CHART ;
S X=$$ENC^AMHRLU2(AMHPAT)
D TX
SEX ;
I AUPNSEX="" S AMHE="E014" Q
S X=AUPNSEX D TX
DOB ;
I AUPNDOB="" S AMHE="E015" Q
S X=AUPNDOB D TX
I '$D(^AUPNPAT(AMHPAT,11)) S AMHE="E016" Q
COMRES ;
S Y=0,AMHCOM="" F S Y=$O(^AUPNPAT(AMHPAT,51,Y)) Q:Y'=+Y S AMHCOM=Y
I AMHCOM="" S AMHE="E016" Q
S AMHCOM=$P(^AUPNPAT(AMHPAT,51,AMHCOM,0),U,3) I AMHCOM="" S AMHE="E017" Q
I '$D(^AUTTCOM(AMHCOM,0)) S AMHE="E017" Q
I AMHCOM]"" S X=$P(^AUTTCOM(AMHCOM,0),U,8) I X="" S AMHE="E017" Q
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 AMHE="E018" Q
I $P(^AUTTTRI(X,0),U,4)="Y" S AMHE="E019" Q
S X=$P(^AUTTTRI(X,0),U,2) I X="" S AMHE="E020" Q
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 ;EP
S X=$$PI^AMHRLU(AMHPAT,$P($P(AMHREC,U),"."))
S X=$S(X:"Y",1:"N")
D TX
EM ;evaluation&management
S X=$P(AMHREC,U,29)
S X=$S(X="":" ",1:$P($$CPT^ICPTCOD(X,$P($P(AMHREC,U),".")),U,2))
D TX
CPT1 ;
S Y=$O(^AMHRPROC("AD",AMHR,0))
S X=$S(Y="":" ",1:$P($$CPT^ICPTCOD($P(^AMHRPROC(Y,0),U),$P($P(^AMHREC(AMHR,0),U),".")),U,2))
D TX
CPT2 ;
S C=0,Y=0 F S Y=$O(^AMHRPROC("AD",AMHR,Y)) Q:Y'=+Y!(C=2) S C=C+1 I C=2 S %=Y
S X=$S($G(%)="":" ",1:$P($$CPT^ICPTCOD($P(^AMHRPROC(%,0),U),$P($P(^AMHREC(AMHR,0),U),".")),U,2))
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
AMHEXD2 ; IHS/CMI/LAB - PROCESS RECORD ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;
+3 ;encryted patient id info, fixed sec prov to check for unknown
+4 ;
RECORD ;EP
+1 SET (AMHE,AMHTX)=""
KILL AMHRTYPE
+2 IF '$DATA(^AMHREC(AMHR))
SET AMHE="E026"
QUIT
RECTYPE IF AMHO("RUN")="NEW"
SET X=$PIECE(AMHREC,U,22)
IF X=""
SET X=$SELECT($PIECE(AMHREC,U,24)]"":"M",1:"A")
+1 IF AMHO("RUN")="REDO"
SET X=$PIECE(^AMHXLOG(AMH("RUN LOG"),21,AMHR,0),U,3)
IF X=""
SET X="A"
+2 DO TX
DATE SET X=$PIECE($PIECE(AMHREC,U),".")
IF X=""
SET AMHE="E001"
QUIT
+1 DO TX
DUZ2 SET X=$PIECE(^AUTTLOC(DUZ(2),0),U,10)
IF X=""!($LENGTH(X)'=6)
SET AMHE="E002"
QUIT
+1 DO TX
SET AMHDUZ2=X
PROG SET X=$PIECE(AMHREC,U,2)
IF X=""
SET AMHE="E003"
QUIT
+1 DO TX
LOENC SET X=$PIECE(AMHREC,U,4)
IF X=""
SET AMHE="E004"
QUIT
+1 SET X=$PIECE(^AUTTLOC(X,0),U,10)
IF X=""!($LENGTH(X)'=6)
SET AMHE="E005"
QUIT
+2 DO TX
SET AMHLOC=X
COMM SET AMHCOM=$PIECE(AMHREC,U,5)
IF AMHCOM=""
SET AMHE="E006"
QUIT
+1 SET X=$PIECE(^AUTTCOM(AMHCOM,0),U,8)
IF X=""
SET AMHE="E007"
QUIT
+2 IF $LENGTH(X)'=7
SET AMHE="E007"
QUIT
+3 DO TX
+4 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)
+5 SET X=$GET(AMHTMP(9999999.05,AMHCOM,.11992,"E"))_$GET(AMHTMP(9999999.05,AMHCOM,.11991,"E"))_$PIECE(^AUTTCOM(AMHCOM,0),U,7)
+6 IF $LENGTH(X)'=7
SET X=" "
+7 DO TX
ACT SET X=$PIECE(AMHREC,U,6)
IF X=""
SET AMHE="E009"
QUIT
+1 IF '$DATA(^AMHTACT(X))
SET AMHE="E009"
QUIT
+2 SET X=$PIECE(^AMHTACT(X,0),U)
IF X=""
SET AMHE="E009"
QUIT
+3 DO TX
CONT SET X=$PIECE(AMHREC,U,7)
IF X=""
SET AMHE="E010"
QUIT
+1 IF '$DATA(^AMHTSET(X))
SET AMHE="E010"
QUIT
+2 SET X=$PIECE(^AMHTSET(X,0),U,2)
IF X=""
SET AMHE="E010"
QUIT
+3 IF $LENGTH(X)=2
SET X=0
+4 DO TX
NS ;S X=$P(AMHREC,U,9) I 'X S AMHE="E011" Q
+1 SET X=$PIECE(AMHREC,U,9)
IF X=""
SET X=0
+2 SET X=$$LZERO(X,3)
+3 DO TX
MIN SET X=$PIECE(AMHREC,U,12)
IF 'X
SET AMHE="E012"
QUIT
+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 IF '$DATA(^AMHRPROV("AD",AMHR))
SET AMHE="E022"
QUIT
+2 SET AMHAFF=$$PPAFFL^AMHUTIL(AMHR,"I")
IF AMHAFF=""!(AMHAFF["?")
SET AMHE="E023"
QUIT
+3 SET AMHDISC=$$PPCLSC^AMHUTIL(AMHR)
IF AMHDISC=""!(AMHDISC["?")
SET AMHE="E024"
QUIT
+4 SET AMHINI=$$PPINI^AMHUTIL(AMHR)
IF AMHINI["?"
SET AMHE="E025"
QUIT
+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!(AMHE]"")
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 AMHE="E023"
QUIT
+3 SET AMHDISC=$$PROVCLSC^XBFUNC1(AMHX)
IF AMHDISC=""!(AMHDISC["?")!(AMHDISC["UNKNOWN")
SET AMHE="E024"
QUIT
+4 SET AMHINI=$$PROVINI^XBFUNC1(AMHX)
IF AMHINI=""!(AMHINI["?")
SET AMHE="E025"
QUIT
+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
+10 IF AMHE]""
QUIT
POVS ;get problems first 4
+1 IF '$DATA(^AMHRPRO("AD",AMHR))
SET AMHE="E021"
QUIT
+2 SET (AMHRIEN,AMHC)=0
FOR
SET AMHRIEN=$ORDER(^AMHRPRO("AD",AMHR,AMHRIEN))
IF AMHRIEN'=+AMHRIEN!(AMHC=4)
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=$$LBLK($PIECE(AMHREC,U,8),40)
DO TX
QUIT
+2 SET AMHPAT=$PIECE(AMHREC,U,8)
+3 SET Y=AMHPAT
DO ^AUPNPAT
+4 SET AMHNAME=$PIECE(^DPT(AMHPAT,0),U)
+5 IF AMHNAME="DEMO,PATIENT"
SET X=""
SET X=$$LBLK(X,40)
DO TX
QUIT
CHART ;
+1 SET X=$$ENC^AMHRLU2(AMHPAT)
+2 DO TX
SEX ;
+1 IF AUPNSEX=""
SET AMHE="E014"
QUIT
+2 SET X=AUPNSEX
DO TX
DOB ;
+1 IF AUPNDOB=""
SET AMHE="E015"
QUIT
+2 SET X=AUPNDOB
DO TX
+3 IF '$DATA(^AUPNPAT(AMHPAT,11))
SET AMHE="E016"
QUIT
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 AMHE="E016"
QUIT
+3 SET AMHCOM=$PIECE(^AUPNPAT(AMHPAT,51,AMHCOM,0),U,3)
IF AMHCOM=""
SET AMHE="E017"
QUIT
+4 IF '$DATA(^AUTTCOM(AMHCOM,0))
SET AMHE="E017"
QUIT
+5 IF AMHCOM]""
SET X=$PIECE(^AUTTCOM(AMHCOM,0),U,8)
IF X=""
SET AMHE="E017"
QUIT
+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 AMHE="E018"
QUIT
+2 IF $PIECE(^AUTTTRI(X,0),U,4)="Y"
SET AMHE="E019"
QUIT
+3 SET X=$PIECE(^AUTTTRI(X,0),U,2)
IF X=""
SET AMHE="E020"
QUIT
+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 ;EP
+1 SET X=$$PI^AMHRLU(AMHPAT,$PIECE($PIECE(AMHREC,U),"."))
+2 SET X=$SELECT(X:"Y",1:"N")
+3 DO TX
EM ;evaluation&management
+1 SET X=$PIECE(AMHREC,U,29)
+2 SET X=$SELECT(X="":" ",1:$PIECE($$CPT^ICPTCOD(X,$PIECE($PIECE(AMHREC,U),".")),U,2))
+3 DO TX
CPT1 ;
+1 SET Y=$ORDER(^AMHRPROC("AD",AMHR,0))
+2 SET X=$SELECT(Y="":" ",1:$PIECE($$CPT^ICPTCOD($PIECE(^AMHRPROC(Y,0),U),$PIECE($PIECE(^AMHREC(AMHR,0),U),".")),U,2))
+3 DO TX
CPT2 ;
+1 SET C=0
SET Y=0
FOR
SET Y=$ORDER(^AMHRPROC("AD",AMHR,Y))
IF Y'=+Y!(C=2)
QUIT
SET C=C+1
IF C=2
SET %=Y
+2 SET X=$SELECT($GET(%)="":" ",1:$PIECE($$CPT^ICPTCOD($PIECE(^AMHRPROC(%,0),U),$PIECE($PIECE(^AMHREC(AMHR,0),U),".")),U,2))
+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
