- 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