AMHEXD2.m

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