AMHPCCL1 ; IHS/CMI/LAB - CONTINUATION OF AMHPCCL ; 19 Sep 2014 8:37 AM
;;4.0;IHS BEHAVIORAL HEALTH;**2,4,5,6**;JUN 02, 2010;Build 10
;
;
KILL ;
K APCDALVR,APCDPAT,APCDLOC,APCDTYPE,APCDCAT,APCDCLN,APCDTPRO,APCDTPS,APCDTPOV,APCDTNQ,APCDTTOP,APCDTLOU,APCDTPRV,APCDTAT,APCDATMP,APCDAFLG,APCDAUTO,APCDANE,AUPNTALK,AMHPOVP,AMHICDP
Q
AHPRV(V,P) ;EP is this provider already on the visit?
NEW Y,Z,G
S G=0
S Y=0 F S Y=$O(^AUPNVPRV("AD",V,Y)) Q:Y'=+Y!(G) D
.I $P($G(^AUPNVPRV(Y,0)),U)=P S G=1
.Q
Q G
VFILES ;EP Create v file entries
S Y=$P(AMHR0,U,8) I Y D ^AUPNPAT
PROV ;
S AMHX=0 F S AMHX=$O(^AMHRPROV("AD",AMHR,AMHX)) Q:AMHX'=+AMHX D
.D KILL
.Q:$$AHPRV(AMHVSIT,$P(^AMHRPROV(AMHX,0),U))
.S APCDALVR("APCDVSIT")=AMHVSIT
.S APCDALVR("APCDATMP")="[APCDALVR 9000010.06 (ADD)]"
.I $P(^DD(9000010.06,.01,0),U,2)[6 S P=$P(^AMHRPROV(AMHX,0),U),A=$P(^DIC(3,P,0),U,16) D K A,P Q:X=""
..S X=""
..I A="" D E9 Q
..I $P(^VA(200,P,0),U)'=$P(^DIC(16,A,0),U) D E9 Q
..S X=A
.I $P(^DD(9000010.06,.01,0),U,2)[200 S X=$P(^AMHRPROV(AMHX,0),U)
.I X]"" S APCDALVR("APCDTPRO")="`"_X
.S APCDALVR("APCDPAT")=$P(AMHR0,U,8)
.S APCDALVR("APCDTPS")=$P(^AMHRPROV(AMHX,0),U,4)
.D ^APCDALVR
.I $D(APCDALVR("APCDAFLG")) S AMHBN="VFILE",AMHVFILE="V PROVIDER" D @("E"_APCDALVR("APCDAFLG"))
.Q
POV ;create V POVS
S (AMHX,AMHGOT)=0 F S AMHX=$O(^AMHRPRO("AD",AMHR,AMHX)) Q:AMHX'=+AMHX D
.I AMHGOT,AMHLPCCT=2 Q
.D KILL
.S AMHPOVP=$P(^AMHRPRO(AMHX,0),U)
.S AMHIMP=$$IMP^AMHUTIL2($P($P(^AMHREC(AMHR,0),U,1),".",1))
.I AMHIMP=1 Q:$P(^AMHPROB(AMHPOVP,0),U,5)=""
.I AMHIMP=30 Q:$P(^AMHPROB(AMHPOVP,0),U,17)=""
.S APCDALVR("APCDVSIT")=AMHVSIT
.S APCDALVR("APCDATMP")="[APCDALVR 9000010.07 (ADD)]"
.S APCDALVR("APCDPAT")=$P(AMHR0,U,8)
.S APCDALVR("APCDOVRR")=""
.I $$PPINT^AMHUTIL(AMHR)]"",$D(^AMHSITE(DUZ(2),11,"B",$$PPINT^AMHUTIL(AMHR))) D PROVEXCP Q:'$D(APCDALVR("APCDTPOV")) I 1
.E D @AMHLPCCT ;-- get pov and narrative based on pcc type of link
.;S AMHICDP=$O(^ICD9("AB",APCDALVR("APCDTPOV"),0)) ;CSV
.I AMHIMP=30 S AMHICDP=+$$CODEN^ICDEX(APCDALVR("APCDTPOV"),80)
.I AMHIMP=1 S AMHICDP=+$$CODEN^ICDCODE(APCDALVR("APCDTPOV"),80)
.I AMHIMP=30 S %=+$$CODEN^ICDEX(APCDALVR("APCDTPOV"),80) Q:'% Q:%=-1
.I AMHIMP=1 S %=+$$CODEN^ICDCODE(APCDALVR("APCDTPOV"),80) Q:'% Q:%=-1
.S APCDALVR("APCDTPOV")="`"_%
.D ^APCDALVR
.I $D(APCDALVR("APCDAFLG")) S AMHBN="VFILE",AMHVFILE="V POV" D @("E"_APCDALVR("APCDAFLG")) Q
.S AMHGOT=AMHGOT+1
.Q
MEDPROB ;
S AMHX=0 F S AMHX=$O(^AMHRTMDP("AD",AMHR,AMHX)) Q:AMHX'=+AMHX D
.D KILL
.S APCDALVR("APCDVSIT")=AMHVSIT
.S APCDALVR("APCDATMP")="[APCDALVR 9000010.07 (ADD)]"
.S APCDALVR("APCDTPOV")=".9999"
.S APCDALVR("APCDPAT")=$P(AMHR0,U,8)
.S APCDALVR("APCDTNQ")="`"_$P(^AMHRTMDP(AMHX,0),U)
.S APCDALVR("APCDOVRR")=""
.D ^APCDALVR
.I $D(APCDALVR("APCDAFLG")) S AMHBN="VFILE",AMHVFILE="V POV" D @("E"_APCDALVR("APCDAFLG"))
.Q
AT ;create v activity time record
D KILL
S APCDALVR("APCDVSIT")=AMHVSIT
S APCDALVR("APCDATMP")="[APCDALVR 9000010.19 (ADD)]"
S APCDALVR("APCDTACT")=$P(AMHR0,U,12)
S APCDALVR("APCDPAT")=$P(AMHR0,U,8)
S APCDALVR("APCDTTSG")=$P($G(^AMHREC(AMHR,11)),U,4)
D ^APCDALVR
I $D(APCDALVR("APCDAFLG")) S AMHBN="VFILE",AMHVFILE="V ACTIVITY TIME" D @("E"_APCDALVR("APCDAFLG"))
CPT ;pass v cpt's
S AMHX=0 F S AMHX=$O(^AMHRPROC("AD",AMHR,AMHX)) Q:AMHX'=+AMHX D
.D KILL
.S APCDALVR("APCDVSIT")=AMHVSIT
.S APCDALVR("APCDATMP")="[APCDALVR 9000010.18 (ADD)]"
.S APCDALVR("APCDTCPT")="`"_$P(^AMHRPROC(AMHX,0),U)
.S APCDALVR("APCDPAT")=$P(AMHR0,U,8)
.I $P(^AMHRPROC(AMHX,0),U,8)]"" S APCDALVR("APCDTM1")="`"_$P(^AMHRPROC(AMHX,0),U,8)
.I $P(^AMHRPROC(AMHX,0),U,9)]"" S APCDALVR("APCDTM2")="`"_$P(^AMHRPROC(AMHX,0),U,9)
.S APCDALVR("APCDTUN")=$P(^AMHRPROC(AMHX,0),U,16)
.D ^APCDALVR
.I $D(APCDALVR("APCDAFLG")) S AMHBN="VFILE",AMHVFILE="V CPT" D @("E"_APCDALVR("APCDAFLG"))
.Q
EDUC ;education provided
S AMHX=0 F S AMHX=$O(^AMHREDU("AD",AMHR,AMHX)) Q:AMHX'=+AMHX D
.D KILL
.S APCDALVR("APCDVSIT")=AMHVSIT
.S APCDALVR("APCDATMP")="[APCDALVR 9000010.16 (ADD)]"
.S APCDALVR("APCDTTOP")="`"_$P(^AMHREDU(AMHX,0),U)
.S APCDALVR("APCDPAT")=$P(AMHR0,U,8)
.S X=$P(^AMHREDU(AMHX,0),U,4) I X D I X S APCDALVR("APCDTPRO")="`"_X,APCDALVR("APCDTPRV")="`"_X
..I $P(^DD(9000010.16,.05,0),U,2)[6 S X=$G(^DIC(16,X,"A3"))
..Q
.S APCDALVR("APCDTIG")=$P(^AMHREDU(AMHX,0),U,5)
.S APCDALVR("APCDTMIN")=$P(^AMHREDU(AMHX,0),U,6)
.S APCDALVR("APCDTCPT")=$P(^AMHREDU(AMHX,0),U,7) I APCDALVR("APCDTCPT")]"" S APCDALVR("APCDTCPT")="`"_APCDALVR("APCDTCPT")
.S APCDALVR("APCDTLOU")=$P(^AMHREDU(AMHX,0),U,8)
.S APCDALVR("APCDTOBJ")=$P(^AMHREDU(AMHX,0),U,9) S X=+$P(^DD(9000010.16,.14,0),">",2) S APCDALVR("APCDTOBJ")=$E(APCDALVR("APCDTOBJ"),1,X)
.S APCDALVR("APCDTBC")=$P(^AMHREDU(AMHX,0),U,11)
.S APCDALVR("APCDTCOM")=$P($G(^AMHREDU(AMHX,11)),U)
.S APCDALVR("APCDTRTL")=$P($G(^AMHREDU(AMHX,11)),U,2) I APCDALVR("APCDTRTL")]"" S APCDALVR("APCDTRTL")="`"_APCDALVR("APCDTRTL")
.D ^APCDALVR
.I $D(APCDALVR("APCDAFLG")) S AMHBN="VFILE",AMHVFILE="V PATIENT ED" D @("E"_APCDALVR("APCDAFLG")) Q
.;for now only till apcd patch goes out
.I $P($G(^AMHREDU(AMHX,11)),U,2)]"" S DIE="^AUPNVPED(",DA=APCDALVR("APCDADFN"),DR="1102////"_$P(^AMHREDU(AMHX,11),U,2) D ^DIE K DA,DR,DIE
.Q
;
VHF ;PASS HEALTH FACTORS
S AMHX=0 F S AMHX=$O(^AMHRHF("AD",AMHR,AMHX)) Q:AMHX'=+AMHX D
.D KILL
.S APCDALVR("APCDVSIT")=AMHVSIT
.S APCDALVR("APCDATMP")="[APCDALVR 9000010.23 (ADD)]"
.S APCDALVR("APCDTHF")="`"_$P(^AMHRHF(AMHX,0),U)
.S APCDALVR("APCDPAT")=$P(AMHR0,U,8)
.S X=$P(^AMHRHF(AMHX,0),U,5) I X D I X S APCDALVR("APCDTPRO")="`"_X
..I $P(^DD(9000010.23,.05,0),U,2)[6 S X=$G(^DIC(16,X,"A3"))
..Q
.S APCDALVR("APCDTLS")=$P(^AMHRHF(AMHX,0),U,4)
.S APCDALVR("APCDTQTY")=$P(^AMHRHF(AMHX,0),U,6)
.S APCDALVR("APCDTCOM")=$P($G(^AMHRHF(AMHX,811)),U)
.D ^APCDALVR
.I $D(APCDALVR("APCDAFLG")) S AMHBN="VFILE",AMHVFILE="V HEALTH FACTORS" D @("E"_APCDALVR("APCDAFLG")) Q
.Q
;
VMR ;PASS MEASUREMENTS
S AMHX=0 F S AMHX=$O(^AMHRMSR("AD",AMHR,AMHX)) Q:AMHX'=+AMHX D
.D KILL
.S APCDALVR("APCDVSIT")=AMHVSIT
.S APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]"
.S APCDALVR("APCDTTYP")="`"_$P(^AMHRMSR(AMHX,0),U)
.S APCDALVR("APCDPAT")=$P(AMHR0,U,8)
.S APCDALVR("APCDTVAL")=$P(^AMHRMSR(AMHX,0),U,4)
.D ^APCDALVR
.I $D(APCDALVR("APCDAFLG")) S AMHBN="VFILE",AMHVFILE="V MEASUREMENT" D @("E"_APCDALVR("APCDAFLG")) Q
.Q
;
EXAM ;
I $P($G(^AMHREC(AMHR,14)),U,1)]"" D
.Q:$O(^AUTTEXAM("C",34,0))=""
.S AMHRES=$$VAL^XBDIQ1(9002011,AMHR,1401) I AMHRES["NEG" S AMHRES="N"
.S AMHP=$P(^AMHREC(AMHR,14),U,2),AMHCOM=$P($G(^AMHREC(AMHR,15)),U) ;,AMHCOM=$TR(AMHCOM,";",":")
.I AMHRES["REFUSED"!(AMHRES["UNABLE") S AMHEXCDE=34 D REF K AMHEXCDE Q
.D KILL S APCDALVR("APCDVSIT")=AMHVSIT
.S APCDALVR("APCDATMP")="[APCDALVR 9000010.13 (ADD)]"
.S APCDALVR("APCDTEX")=34
.S APCDALVR("APCDPAT")=$P(AMHR0,U,8)
.S APCDALVR("APCDTRES")=AMHRES
.S APCDALVR("APCDTCOM")=AMHCOM
.S APCDALVR("APCDTEPR")="" I AMHP S APCDALVR("APCDTEPR")="`"_AMHP
.D ^APCDALVR
.I $D(APCDALVR("APCDAFLG")) S AMHBN="VFILE",AMHVFILE="V EXAM" D @("E"_APCDALVR("APCDAFLG"))
.Q
I $P($G(^AMHREC(AMHR,14)),U,3)]"" D
.Q:$O(^AUTTEXAM("C",35,0))=""
.S AMHRES=$$VAL^XBDIQ1(9002011,AMHR,1403) I AMHRES["NEG" S AMHRES="N"
.S AMHP=$P(^AMHREC(AMHR,14),U,4),AMHCOM=$P($G(^AMHREC(AMHR,16)),U) ;,AMHCOM=$TR(AMHCOM,";",":")
.I AMHRES["REFUSED"!(AMHRES["UNABLE") S AMHEXCDE=35 D REF K AMHEXCDE Q
.D KILL S APCDALVR("APCDVSIT")=AMHVSIT
.S APCDALVR("APCDATMP")="[APCDALVR 9000010.13 (ADD)]"
.S APCDALVR("APCDTEX")=35
.S APCDALVR("APCDPAT")=$P(AMHR0,U,8)
.S APCDALVR("APCDTRES")=AMHRES
.S APCDALVR("APCDTCOM")=AMHCOM
.S APCDALVR("APCDTEPR")="" I AMHP S APCDALVR("APCDTEPR")="`"_AMHP
.D ^APCDALVR
.Q
DEP ;
I $P($G(^AMHREC(AMHR,14)),U,5)]"" D
.Q:$O(^AUTTEXAM("C",36,0))=""
.S AMHRES=$$VAL^XBDIQ1(9002011,AMHR,1405) I AMHRES["NEG" S AMHRES="N"
.S AMHP=$P(^AMHREC(AMHR,14),U,6),AMHCOM=$P($G(^AMHREC(AMHR,17)),U) ;,AMHCOM=$TR(AMHCOM,";",":")
.I AMHRES["REFUSED"!(AMHRES["UNABLE") S AMHEXCDE=36 D REF K AMHEXCDE Q
.D KILL S APCDALVR("APCDVSIT")=AMHVSIT
.S APCDALVR("APCDATMP")="[APCDALVR 9000010.13 (ADD)]"
.S APCDALVR("APCDTEX")=36
.S APCDALVR("APCDPAT")=$P(AMHR0,U,8)
.S APCDALVR("APCDTRES")=AMHRES
.S APCDALVR("APCDTCOM")=AMHCOM
.S APCDALVR("APCDTEPR")="" I AMHP S APCDALVR("APCDTEPR")="`"_AMHP
.D ^APCDALVR
.Q
SRA ;
I $P($G(^AMHREC(AMHR,14)),U,7)]"" D
.Q:$O(^AUTTEXAM("C",43,0))=""
.S AMHRES=$$VAL^XBDIQ1(9002011,AMHR,1407)
.S AMHP=$P(^AMHREC(AMHR,14),U,8),AMHCOM=$P($G(^AMHREC(AMHR,19)),U) ;,AMHCOM=$TR(AMHCOM,";",":")
.I AMHRES["REFUSED"!(AMHRES["UNABLE") S AMHEXCDE=43 D REF K AMHEXCDE Q
.D KILL S APCDALVR("APCDVSIT")=AMHVSIT
.S APCDALVR("APCDATMP")="[APCDALVR 9000010.13 (ADD)]"
.S APCDALVR("APCDTEX")=43
.S APCDALVR("APCDPAT")=$P(AMHR0,U,8)
.S APCDALVR("APCDTRES")=AMHRES
.S APCDALVR("APCDTCOM")=AMHCOM
.S APCDALVR("APCDTEPR")="" I AMHP S APCDALVR("APCDTEPR")="`"_AMHP
.D ^APCDALVR
.Q
;V UPDATED/REVIEWED IF NEEDED
I $P($G(^AMHREC(AMHR,18)),U,1) D
.NEW AMHVAL S AMHVAL=""
.D PLU^APCDAPRB("",AMHVSIT,$P(^AMHREC(AMHR,0),U,8),$P($G(^AMHREC(AMHR,18)),U,1),$P($G(^AMHREC(AMHR,18)),U,2),.AMHVAL)
.Q
I $P($G(^AMHREC(AMHR,18)),U,3) D
.NEW AMHVAL S AMHVAL=""
.D PLRADD^APCDPL1("",AMHVSIT,$P(^AMHREC(AMHR,0),U,8),$P($G(^AMHREC(AMHR,18)),U,3),$P($G(^AMHREC(AMHR,18)),U,4),.AMHVAL)
.Q
I $P($G(^AMHREC(AMHR,18)),U,5) D
.NEW AMHVAL S AMHVAL=""
.D NAPADD^APCDPL1("",AMHVSIT,$P(^AMHREC(AMHR,0),U,8),$P($G(^AMHREC(AMHR,18)),U,5),$P($G(^AMHREC(AMHR,18)),U,6),.AMHVAL)
.Q
Q
REF ;enter refusal into PCC
S X=$O(^AUTTREFT("B","EXAM",0))
Q:X=""
S AMHTIDI=$O(^AUTTEXAM("C",AMHEXCDE,0)) Q:AMHTIDI="" S AMHTID=$P(^AUTTEXAM(AMHTIDI,0),U)
K DIC,DLAYGO,DIADD
S DIC(0)="L",DIC="^AUPNPREF(",DIC("DR")=".02////"_$P(AMHR0,U,8)_";.03////"_$P($P(AMHR0,U),".")_";.04////"_AMHTID_";.05////9999999.15;.06////"_AMHTIDI_";.07////"_$S($E(AMHRES)["UNABLE":"U",AMHRES["REFUSED":"R",1:"")_";1101///"_AMHCOM
K DD,D0 D FILE^DICN
I Y=-1 W !!,"Creating refusal entry failed...." H 2 D ^XBFMK K DIADD,DLAYGO Q
D ^XBFMK
K DIADD,DLAYGO
Q
PROVEXCP ;provider exception to the rule
S Y=$O(^AMHSITE(DUZ(2),11,"B",$$PPINT^AMHUTIL(AMHR),""))
I Y=""!(Y="???") S AMHVFILE="V POV",AMHBN="VFILE" D E8 Q
S X=$P(^AMHSITE(DUZ(2),11,Y,0),U,2)
I X="" S AMHVFILE="V POV",AMHBN="VFILE" D E8 Q
I X=1 Q ;NO PCC LINK AT ALL
D @X
Q
2 ;-- pass standard narrative and code
;S APCDALVR("APCDTPOV")=$S($P(^AMHSITE(DUZ(2),0),U,13)]"":$P(^ICD9($P(^AMHSITE(DUZ(2),0),U,13),0),U),1:"V65.40") ;replace with standard code
I $T(ICDDX^ICDEX)]"" D I 1
.I AMHIMP=1 S APCDALVR("APCDTPOV")=$S($P(^AMHSITE(DUZ(2),0),U,13)]"":$P($$ICDDX^ICDEX($P(^AMHSITE(DUZ(2),0),U,13)),U,2),1:"V65.40") ;replace with standard code
.I AMHIMP=30 S APCDALVR("APCDTPOV")=$S($P($G(^AMHSITE(DUZ(2),12)),U,4)]"":$P($$ICDDX^ICDEX($P(^AMHSITE(DUZ(2),12),U,4)),U,2),1:"Z71.9")
E D
.I AMHIMP=1 S APCDALVR("APCDTPOV")=$S($P(^AMHSITE(DUZ(2),0),U,13)]"":$P($$ICDDX^ICDCODE($P(^AMHSITE(DUZ(2),0),U,13)),U,2),1:"V65.40") ;replace with standard code
.I AMHIMP=30 S APCDALVR("APCDTPOV")=$S($P($G(^AMHSITE(DUZ(2),12)),U,4)]"":$P($$ICDDX^ICDCODE($P(^AMHSITE(DUZ(2),12),U,4)),U,2),1:"Z71.9")
I AMHPTYPE="M" S APCDALVR("APCDTNQ")=$S($$MHNARR^AMHLEIN(DUZ(2))]"":$$MHNARR^AMHLEIN(DUZ(2)),1:"MENTAL HEALTH") Q ;replace
I AMHPTYPE="S" S APCDALVR("APCDTNQ")=$S($$SSNARR^AMHLEIN(DUZ(2))]"":$$SSNARR^AMHLEIN(DUZ(2)),1:"SOCIAL SERVICE VISIT") Q ;replace
I AMHPTYPE="C" S APCDALVR("APCDTNQ")=$S($$CDNARR^AMHLEIN(DUZ(2))]"":$$CDNARR^AMHLEIN(DUZ(2)),1:"CHEMICAL DEPENDENCY VISIT") Q ;replace
I AMHPTYPE="O" S APCDALVR("APCDTNQ")=$S($$OTNARR^AMHLEIN(DUZ(2))]"":$$OTNARR^AMHLEIN(DUZ(2)),1:"BEHAVIOR HEALTH VISIT") Q ;replace
S APCDALVR("APCDTNQ")="BEHAVIORAL HEALTH VISIT"
Q
;
3 ;crosswalk (mask some stuff, no other)
S APCDALVR("APCDTPOV")=$P(^AMHPROB(AMHPOVP,0),U,5)
I '$P(^AMHPROB(AMHPOVP,0),U,8) S APCDALVR("APCDTNQ")="`"_$P(^AMHRPRO(AMHX,0),U,4)
K AMHERR I $P(^AMHPROB(AMHPOVP,0),U,8) D Q:$D(AMHERR)
.;S X=$P(^AMHPROB(AMHPOVP,0),U,5),Y=$O(^ICD9("AB",X,"")) ;CSV
.S X=$P(^AMHPROB(AMHPOVP,0),U,5),Y=+$$CODEN^ICDCODE(X,80) ;CSV
.I Y=""!(Y=-1) S AMHBN="VFILE",AMHVFILE="V POV" D E2 S AMHERR=1 Q
.I $T(ICDDX^ICDEX)="" S APCDALVR("APCDTNQ")=$E($P($$ICDDX^ICDCODE(Y,$P($P(^AMHREC(AMHR,0),U),".")),U,4),1,79)
.I $T(ICDDX^ICDEX)]"" S APCDALVR("APCDTNQ")=$E($P($$ICDDX^ICDEX(Y,$P($P(^AMHREC(AMHR,0),U),".")),U,4),1,79)
.I $P(^AMHPROB(AMHPOVP,0),U,9) S APCDALVR("APCDTNQ")=$E(APCDALVR("APCDTNQ"),1,42)_" SEE "_$E($$PPNAME^AMHUTIL(AMHR),1,18)_" FOR DETAILS"
.I $P(^AMHPROB(AMHPOVP,0),U,11) S APCDALVR("APCDTNQ")="DIAGNOSTIC IMPRESSION: "_$E(APCDALVR("APCDTNQ"),1,55)
.I $P(^AMHPROB(AMHPOVP,0),U,12) S APCDALVR("APCDTNQ")=$E($P(^AMHPROB(AMHPOVP,0),U,2),1,35)_" - "_$E($$GET1^DIQ(9002011.01,AMHX,.04),1,40)
Q
;
4 ;
I AMHIMP=1 S APCDALVR("APCDTPOV")=$P(^AMHPROB(AMHPOVP,0),U,5)
I AMHIMP=30 S APCDALVR("APCDTPOV")=$P(^AMHPROB(AMHPOVP,0),U,17)
S APCDALVR("APCDTNQ")="`"_$P(^AMHRPRO(AMHX,0),U,4)
Q
5 ;
I AMHIMP=1 S APCDALVR("APCDTPOV")=$P(^AMHPROB(AMHPOVP,0),U,5)
I AMHIMP=30 S APCDALVR("APCDTPOV")=$P(^AMHPROB(AMHPOVP,0),U,17)
I AMHPTYPE="M" S APCDALVR("APCDTNQ")=$S($$MHNARR^AMHLEIN(DUZ(2))]"":$$MHNARR^AMHLEIN(DUZ(2)),1:"MENTAL HEALTH") Q ;replace
I AMHPTYPE="S" S APCDALVR("APCDTNQ")=$S($$SSNARR^AMHLEIN(DUZ(2))]"":$$SSNARR^AMHLEIN(DUZ(2)),1:"SOCIAL SERVICE VISIT") Q ;replace
I AMHPTYPE="C" S APCDALVR("APCDTNQ")=$S($$CDNARR^AMHLEIN(DUZ(2))]"":$$CDNARR^AMHLEIN(DUZ(2)),1:"CHEMICAL DEPENDENCY VISIT") Q ;replace
I AMHPTYPE="O" S APCDALVR("APCDTNQ")=$S($$OTNARR^AMHLEIN(DUZ(2))]"":$$OTNARR^AMHLEIN(DUZ(2)),1:"BEHAVIOR HEALTH VISIT") Q ;replace
S APCDALVR("APCDTNQ")="BEHAVIORAL HEALTH VISIT"
Q
V2 S AMHERROR="inability to create visit" G LBULL
V3 S AMHERROR="invalid visit parameters (date, location etc.)" G LBULL
;
E1 S AMHERROR="incorrect template specification" G LBULL
E2 S AMHERROR="invalid values being passed to "_AMHVFILE G LBULL
E8 S AMHERROR="Provider specific link not complete in site file "_$$PPNAME^AMHUTIL(AMHR) G LBULL
E9 S AMHERROR="Could not resolve file 200-file 6 pointer for V PROVIDER. "_$P(^VA(200,X,0),U) G LBULL
;
LBULL ;
K XMB
S XMDUZ="BEHAVIORAL HEALTH"
S XMB(1)=AMHR,XMB(2)=$P(^DPT($P(AMHR0,U,8),0),U)_" (DFN "_$P(AMHR0,U,8)_")",Y=$P(AMHR0,U) D DD^%DT S XMB(3)=Y,XMB(4)=AMHERROR,XMB(5)=$G(AMHVFILE),XMB="AMH PCC LINK FAIL "_AMHBN ;,AMHDUZ=DUZ,DUZ=.5
D ^XMB K XMB,AMHERROR,AMHBN,AMHVFILE,XMDUZ
Q
AMHPCCL1 ; IHS/CMI/LAB - CONTINUATION OF AMHPCCL ; 19 Sep 2014 8:37 AM
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**2,4,5,6**;JUN 02, 2010;Build 10
+2 ;
+3 ;
KILL ;
+1 KILL APCDALVR,APCDPAT,APCDLOC,APCDTYPE,APCDCAT,APCDCLN,APCDTPRO,APCDTPS,APCDTPOV,APCDTNQ,APCDTTOP,APCDTLOU,APCDTPRV,APCDTAT,APCDATMP,APCDAFLG,APCDAUTO,APCDANE,AUPNTALK,AMHPOVP,AMHICDP
+2 QUIT
AHPRV(V,P) ;EP is this provider already on the visit?
+1 NEW Y,Z,G
+2 SET G=0
+3 SET Y=0
FOR
SET Y=$ORDER(^AUPNVPRV("AD",V,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^AUPNVPRV(Y,0)),U)=P
SET G=1
+5 QUIT
End DoDot:1
+6 QUIT G
VFILES ;EP Create v file entries
+1 SET Y=$PIECE(AMHR0,U,8)
IF Y
DO ^AUPNPAT
PROV ;
+1 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRPROV("AD",AMHR,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+2 DO KILL
+3 IF $$AHPRV(AMHVSIT,$PIECE(^AMHRPROV(AMHX,0),U))
QUIT
+4 SET APCDALVR("APCDVSIT")=AMHVSIT
+5 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.06 (ADD)]"
+6 IF $PIECE(^DD(9000010.06,.01,0),U,2)[6
SET P=$PIECE(^AMHRPROV(AMHX,0),U)
SET A=$PIECE(^DIC(3,P,0),U,16)
Begin DoDot:2
+7 SET X=""
+8 IF A=""
DO E9
QUIT
+9 IF $PIECE(^VA(200,P,0),U)'=$PIECE(^DIC(16,A,0),U)
DO E9
QUIT
+10 SET X=A
End DoDot:2
KILL A,P
IF X=""
QUIT
+11 IF $PIECE(^DD(9000010.06,.01,0),U,2)[200
SET X=$PIECE(^AMHRPROV(AMHX,0),U)
+12 IF X]""
SET APCDALVR("APCDTPRO")="`"_X
+13 SET APCDALVR("APCDPAT")=$PIECE(AMHR0,U,8)
+14 SET APCDALVR("APCDTPS")=$PIECE(^AMHRPROV(AMHX,0),U,4)
+15 DO ^APCDALVR
+16 IF $DATA(APCDALVR("APCDAFLG"))
SET AMHBN="VFILE"
SET AMHVFILE="V PROVIDER"
DO @("E"_APCDALVR("APCDAFLG"))
+17 QUIT
End DoDot:1
POV ;create V POVS
+1 SET (AMHX,AMHGOT)=0
FOR
SET AMHX=$ORDER(^AMHRPRO("AD",AMHR,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+2 IF AMHGOT
IF AMHLPCCT=2
QUIT
+3 DO KILL
+4 SET AMHPOVP=$PIECE(^AMHRPRO(AMHX,0),U)
+5 SET AMHIMP=$$IMP^AMHUTIL2($PIECE($PIECE(^AMHREC(AMHR,0),U,1),".",1))
+6 IF AMHIMP=1
IF $PIECE(^AMHPROB(AMHPOVP,0),U,5)=""
QUIT
+7 IF AMHIMP=30
IF $PIECE(^AMHPROB(AMHPOVP,0),U,17)=""
QUIT
+8 SET APCDALVR("APCDVSIT")=AMHVSIT
+9 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.07 (ADD)]"
+10 SET APCDALVR("APCDPAT")=$PIECE(AMHR0,U,8)
+11 SET APCDALVR("APCDOVRR")=""
+12 IF $$PPINT^AMHUTIL(AMHR)]""
IF $DATA(^AMHSITE(DUZ(2),11,"B",$$PPINT^AMHUTIL(AMHR)))
DO PROVEXCP
IF '$DATA(APCDALVR("APCDTPOV"))
QUIT
IF 1
+13 ;-- get pov and narrative based on pcc type of link
IF '$TEST
DO @AMHLPCCT
+14 ;S AMHICDP=$O(^ICD9("AB",APCDALVR("APCDTPOV"),0)) ;CSV
+15 IF AMHIMP=30
SET AMHICDP=+$$CODEN^ICDEX(APCDALVR("APCDTPOV"),80)
+16 IF AMHIMP=1
SET AMHICDP=+$$CODEN^ICDCODE(APCDALVR("APCDTPOV"),80)
+17 IF AMHIMP=30
SET %=+$$CODEN^ICDEX(APCDALVR("APCDTPOV"),80)
IF '%
QUIT
IF %=-1
QUIT
+18 IF AMHIMP=1
SET %=+$$CODEN^ICDCODE(APCDALVR("APCDTPOV"),80)
IF '%
QUIT
IF %=-1
QUIT
+19 SET APCDALVR("APCDTPOV")="`"_%
+20 DO ^APCDALVR
+21 IF $DATA(APCDALVR("APCDAFLG"))
SET AMHBN="VFILE"
SET AMHVFILE="V POV"
DO @("E"_APCDALVR("APCDAFLG"))
QUIT
+22 SET AMHGOT=AMHGOT+1
+23 QUIT
End DoDot:1
MEDPROB ;
+1 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRTMDP("AD",AMHR,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+2 DO KILL
+3 SET APCDALVR("APCDVSIT")=AMHVSIT
+4 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.07 (ADD)]"
+5 SET APCDALVR("APCDTPOV")=".9999"
+6 SET APCDALVR("APCDPAT")=$PIECE(AMHR0,U,8)
+7 SET APCDALVR("APCDTNQ")="`"_$PIECE(^AMHRTMDP(AMHX,0),U)
+8 SET APCDALVR("APCDOVRR")=""
+9 DO ^APCDALVR
+10 IF $DATA(APCDALVR("APCDAFLG"))
SET AMHBN="VFILE"
SET AMHVFILE="V POV"
DO @("E"_APCDALVR("APCDAFLG"))
+11 QUIT
End DoDot:1
AT ;create v activity time record
+1 DO KILL
+2 SET APCDALVR("APCDVSIT")=AMHVSIT
+3 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.19 (ADD)]"
+4 SET APCDALVR("APCDTACT")=$PIECE(AMHR0,U,12)
+5 SET APCDALVR("APCDPAT")=$PIECE(AMHR0,U,8)
+6 SET APCDALVR("APCDTTSG")=$PIECE($GET(^AMHREC(AMHR,11)),U,4)
+7 DO ^APCDALVR
+8 IF $DATA(APCDALVR("APCDAFLG"))
SET AMHBN="VFILE"
SET AMHVFILE="V ACTIVITY TIME"
DO @("E"_APCDALVR("APCDAFLG"))
CPT ;pass v cpt's
+1 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRPROC("AD",AMHR,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+2 DO KILL
+3 SET APCDALVR("APCDVSIT")=AMHVSIT
+4 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.18 (ADD)]"
+5 SET APCDALVR("APCDTCPT")="`"_$PIECE(^AMHRPROC(AMHX,0),U)
+6 SET APCDALVR("APCDPAT")=$PIECE(AMHR0,U,8)
+7 IF $PIECE(^AMHRPROC(AMHX,0),U,8)]""
SET APCDALVR("APCDTM1")="`"_$PIECE(^AMHRPROC(AMHX,0),U,8)
+8 IF $PIECE(^AMHRPROC(AMHX,0),U,9)]""
SET APCDALVR("APCDTM2")="`"_$PIECE(^AMHRPROC(AMHX,0),U,9)
+9 SET APCDALVR("APCDTUN")=$PIECE(^AMHRPROC(AMHX,0),U,16)
+10 DO ^APCDALVR
+11 IF $DATA(APCDALVR("APCDAFLG"))
SET AMHBN="VFILE"
SET AMHVFILE="V CPT"
DO @("E"_APCDALVR("APCDAFLG"))
+12 QUIT
End DoDot:1
EDUC ;education provided
+1 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHREDU("AD",AMHR,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+2 DO KILL
+3 SET APCDALVR("APCDVSIT")=AMHVSIT
+4 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.16 (ADD)]"
+5 SET APCDALVR("APCDTTOP")="`"_$PIECE(^AMHREDU(AMHX,0),U)
+6 SET APCDALVR("APCDPAT")=$PIECE(AMHR0,U,8)
+7 SET X=$PIECE(^AMHREDU(AMHX,0),U,4)
IF X
Begin DoDot:2
+8 IF $PIECE(^DD(9000010.16,.05,0),U,2)[6
SET X=$GET(^DIC(16,X,"A3"))
+9 QUIT
End DoDot:2
IF X
SET APCDALVR("APCDTPRO")="`"_X
SET APCDALVR("APCDTPRV")="`"_X
+10 SET APCDALVR("APCDTIG")=$PIECE(^AMHREDU(AMHX,0),U,5)
+11 SET APCDALVR("APCDTMIN")=$PIECE(^AMHREDU(AMHX,0),U,6)
+12 SET APCDALVR("APCDTCPT")=$PIECE(^AMHREDU(AMHX,0),U,7)
IF APCDALVR("APCDTCPT")]""
SET APCDALVR("APCDTCPT")="`"_APCDALVR("APCDTCPT")
+13 SET APCDALVR("APCDTLOU")=$PIECE(^AMHREDU(AMHX,0),U,8)
+14 SET APCDALVR("APCDTOBJ")=$PIECE(^AMHREDU(AMHX,0),U,9)
SET X=+$PIECE(^DD(9000010.16,.14,0),">",2)
SET APCDALVR("APCDTOBJ")=$EXTRACT(APCDALVR("APCDTOBJ"),1,X)
+15 SET APCDALVR("APCDTBC")=$PIECE(^AMHREDU(AMHX,0),U,11)
+16 SET APCDALVR("APCDTCOM")=$PIECE($GET(^AMHREDU(AMHX,11)),U)
+17 SET APCDALVR("APCDTRTL")=$PIECE($GET(^AMHREDU(AMHX,11)),U,2)
IF APCDALVR("APCDTRTL")]""
SET APCDALVR("APCDTRTL")="`"_APCDALVR("APCDTRTL")
+18 DO ^APCDALVR
+19 IF $DATA(APCDALVR("APCDAFLG"))
SET AMHBN="VFILE"
SET AMHVFILE="V PATIENT ED"
DO @("E"_APCDALVR("APCDAFLG"))
QUIT
+20 ;for now only till apcd patch goes out
+21 IF $PIECE($GET(^AMHREDU(AMHX,11)),U,2)]""
SET DIE="^AUPNVPED("
SET DA=APCDALVR("APCDADFN")
SET DR="1102////"_$PIECE(^AMHREDU(AMHX,11),U,2)
DO ^DIE
KILL DA,DR,DIE
+22 QUIT
End DoDot:1
+23 ;
VHF ;PASS HEALTH FACTORS
+1 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRHF("AD",AMHR,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+2 DO KILL
+3 SET APCDALVR("APCDVSIT")=AMHVSIT
+4 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.23 (ADD)]"
+5 SET APCDALVR("APCDTHF")="`"_$PIECE(^AMHRHF(AMHX,0),U)
+6 SET APCDALVR("APCDPAT")=$PIECE(AMHR0,U,8)
+7 SET X=$PIECE(^AMHRHF(AMHX,0),U,5)
IF X
Begin DoDot:2
+8 IF $PIECE(^DD(9000010.23,.05,0),U,2)[6
SET X=$GET(^DIC(16,X,"A3"))
+9 QUIT
End DoDot:2
IF X
SET APCDALVR("APCDTPRO")="`"_X
+10 SET APCDALVR("APCDTLS")=$PIECE(^AMHRHF(AMHX,0),U,4)
+11 SET APCDALVR("APCDTQTY")=$PIECE(^AMHRHF(AMHX,0),U,6)
+12 SET APCDALVR("APCDTCOM")=$PIECE($GET(^AMHRHF(AMHX,811)),U)
+13 DO ^APCDALVR
+14 IF $DATA(APCDALVR("APCDAFLG"))
SET AMHBN="VFILE"
SET AMHVFILE="V HEALTH FACTORS"
DO @("E"_APCDALVR("APCDAFLG"))
QUIT
+15 QUIT
End DoDot:1
+16 ;
VMR ;PASS MEASUREMENTS
+1 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRMSR("AD",AMHR,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+2 DO KILL
+3 SET APCDALVR("APCDVSIT")=AMHVSIT
+4 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]"
+5 SET APCDALVR("APCDTTYP")="`"_$PIECE(^AMHRMSR(AMHX,0),U)
+6 SET APCDALVR("APCDPAT")=$PIECE(AMHR0,U,8)
+7 SET APCDALVR("APCDTVAL")=$PIECE(^AMHRMSR(AMHX,0),U,4)
+8 DO ^APCDALVR
+9 IF $DATA(APCDALVR("APCDAFLG"))
SET AMHBN="VFILE"
SET AMHVFILE="V MEASUREMENT"
DO @("E"_APCDALVR("APCDAFLG"))
QUIT
+10 QUIT
End DoDot:1
+11 ;
EXAM ;
+1 IF $PIECE($GET(^AMHREC(AMHR,14)),U,1)]""
Begin DoDot:1
+2 IF $ORDER(^AUTTEXAM("C",34,0))=""
QUIT
+3 SET AMHRES=$$VAL^XBDIQ1(9002011,AMHR,1401)
IF AMHRES["NEG"
SET AMHRES="N"
+4 ;,AMHCOM=$TR(AMHCOM,";",":")
SET AMHP=$PIECE(^AMHREC(AMHR,14),U,2)
SET AMHCOM=$PIECE($GET(^AMHREC(AMHR,15)),U)
+5 IF AMHRES["REFUSED"!(AMHRES["UNABLE")
SET AMHEXCDE=34
DO REF
KILL AMHEXCDE
QUIT
+6 DO KILL
SET APCDALVR("APCDVSIT")=AMHVSIT
+7 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.13 (ADD)]"
+8 SET APCDALVR("APCDTEX")=34
+9 SET APCDALVR("APCDPAT")=$PIECE(AMHR0,U,8)
+10 SET APCDALVR("APCDTRES")=AMHRES
+11 SET APCDALVR("APCDTCOM")=AMHCOM
+12 SET APCDALVR("APCDTEPR")=""
IF AMHP
SET APCDALVR("APCDTEPR")="`"_AMHP
+13 DO ^APCDALVR
+14 IF $DATA(APCDALVR("APCDAFLG"))
SET AMHBN="VFILE"
SET AMHVFILE="V EXAM"
DO @("E"_APCDALVR("APCDAFLG"))
+15 QUIT
End DoDot:1
+16 IF $PIECE($GET(^AMHREC(AMHR,14)),U,3)]""
Begin DoDot:1
+17 IF $ORDER(^AUTTEXAM("C",35,0))=""
QUIT
+18 SET AMHRES=$$VAL^XBDIQ1(9002011,AMHR,1403)
IF AMHRES["NEG"
SET AMHRES="N"
+19 ;,AMHCOM=$TR(AMHCOM,";",":")
SET AMHP=$PIECE(^AMHREC(AMHR,14),U,4)
SET AMHCOM=$PIECE($GET(^AMHREC(AMHR,16)),U)
+20 IF AMHRES["REFUSED"!(AMHRES["UNABLE")
SET AMHEXCDE=35
DO REF
KILL AMHEXCDE
QUIT
+21 DO KILL
SET APCDALVR("APCDVSIT")=AMHVSIT
+22 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.13 (ADD)]"
+23 SET APCDALVR("APCDTEX")=35
+24 SET APCDALVR("APCDPAT")=$PIECE(AMHR0,U,8)
+25 SET APCDALVR("APCDTRES")=AMHRES
+26 SET APCDALVR("APCDTCOM")=AMHCOM
+27 SET APCDALVR("APCDTEPR")=""
IF AMHP
SET APCDALVR("APCDTEPR")="`"_AMHP
+28 DO ^APCDALVR
+29 QUIT
End DoDot:1
DEP ;
+1 IF $PIECE($GET(^AMHREC(AMHR,14)),U,5)]""
Begin DoDot:1
+2 IF $ORDER(^AUTTEXAM("C",36,0))=""
QUIT
+3 SET AMHRES=$$VAL^XBDIQ1(9002011,AMHR,1405)
IF AMHRES["NEG"
SET AMHRES="N"
+4 ;,AMHCOM=$TR(AMHCOM,";",":")
SET AMHP=$PIECE(^AMHREC(AMHR,14),U,6)
SET AMHCOM=$PIECE($GET(^AMHREC(AMHR,17)),U)
+5 IF AMHRES["REFUSED"!(AMHRES["UNABLE")
SET AMHEXCDE=36
DO REF
KILL AMHEXCDE
QUIT
+6 DO KILL
SET APCDALVR("APCDVSIT")=AMHVSIT
+7 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.13 (ADD)]"
+8 SET APCDALVR("APCDTEX")=36
+9 SET APCDALVR("APCDPAT")=$PIECE(AMHR0,U,8)
+10 SET APCDALVR("APCDTRES")=AMHRES
+11 SET APCDALVR("APCDTCOM")=AMHCOM
+12 SET APCDALVR("APCDTEPR")=""
IF AMHP
SET APCDALVR("APCDTEPR")="`"_AMHP
+13 DO ^APCDALVR
+14 QUIT
End DoDot:1
SRA ;
+1 IF $PIECE($GET(^AMHREC(AMHR,14)),U,7)]""
Begin DoDot:1
+2 IF $ORDER(^AUTTEXAM("C",43,0))=""
QUIT
+3 SET AMHRES=$$VAL^XBDIQ1(9002011,AMHR,1407)
+4 ;,AMHCOM=$TR(AMHCOM,";",":")
SET AMHP=$PIECE(^AMHREC(AMHR,14),U,8)
SET AMHCOM=$PIECE($GET(^AMHREC(AMHR,19)),U)
+5 IF AMHRES["REFUSED"!(AMHRES["UNABLE")
SET AMHEXCDE=43
DO REF
KILL AMHEXCDE
QUIT
+6 DO KILL
SET APCDALVR("APCDVSIT")=AMHVSIT
+7 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.13 (ADD)]"
+8 SET APCDALVR("APCDTEX")=43
+9 SET APCDALVR("APCDPAT")=$PIECE(AMHR0,U,8)
+10 SET APCDALVR("APCDTRES")=AMHRES
+11 SET APCDALVR("APCDTCOM")=AMHCOM
+12 SET APCDALVR("APCDTEPR")=""
IF AMHP
SET APCDALVR("APCDTEPR")="`"_AMHP
+13 DO ^APCDALVR
+14 QUIT
End DoDot:1
+15 ;V UPDATED/REVIEWED IF NEEDED
+16 IF $PIECE($GET(^AMHREC(AMHR,18)),U,1)
Begin DoDot:1
+17 NEW AMHVAL
SET AMHVAL=""
+18 DO PLU^APCDAPRB("",AMHVSIT,$PIECE(^AMHREC(AMHR,0),U,8),$PIECE($GET(^AMHREC(AMHR,18)),U,1),$PIECE($GET(^AMHREC(AMHR,18)),U,2),.AMHVAL)
+19 QUIT
End DoDot:1
+20 IF $PIECE($GET(^AMHREC(AMHR,18)),U,3)
Begin DoDot:1
+21 NEW AMHVAL
SET AMHVAL=""
+22 DO PLRADD^APCDPL1("",AMHVSIT,$PIECE(^AMHREC(AMHR,0),U,8),$PIECE($GET(^AMHREC(AMHR,18)),U,3),$PIECE($GET(^AMHREC(AMHR,18)),U,4),.AMHVAL)
+23 QUIT
End DoDot:1
+24 IF $PIECE($GET(^AMHREC(AMHR,18)),U,5)
Begin DoDot:1
+25 NEW AMHVAL
SET AMHVAL=""
+26 DO NAPADD^APCDPL1("",AMHVSIT,$PIECE(^AMHREC(AMHR,0),U,8),$PIECE($GET(^AMHREC(AMHR,18)),U,5),$PIECE($GET(^AMHREC(AMHR,18)),U,6),.AMHVAL)
+27 QUIT
End DoDot:1
+28 QUIT
REF ;enter refusal into PCC
+1 SET X=$ORDER(^AUTTREFT("B","EXAM",0))
+2 IF X=""
QUIT
+3 SET AMHTIDI=$ORDER(^AUTTEXAM("C",AMHEXCDE,0))
IF AMHTIDI=""
QUIT
SET AMHTID=$PIECE(^AUTTEXAM(AMHTIDI,0),U)
+4 KILL DIC,DLAYGO,DIADD
+5 SET DIC(0)="L"
SET DIC="^AUPNPREF("
SET DIC("DR")=".02////"_$PIECE(AMHR0,U,8)_";.03////"_$PIECE($PIECE(AMHR0,U),".")_";.04////"_AMHTID_";.05////9999999.15;.06////"_AMHTIDI_";.07////"_$SELECT($EXTRACT(AMHRES)["UNABLE":"U",AMHRES["REFUSED":"R",1:"")_";1101///"_AMHCOM
+6 KILL DD,D0
DO FILE^DICN
+7 IF Y=-1
WRITE !!,"Creating refusal entry failed...."
HANG 2
DO ^XBFMK
KILL DIADD,DLAYGO
QUIT
+8 DO ^XBFMK
+9 KILL DIADD,DLAYGO
+10 QUIT
PROVEXCP ;provider exception to the rule
+1 SET Y=$ORDER(^AMHSITE(DUZ(2),11,"B",$$PPINT^AMHUTIL(AMHR),""))
+2 IF Y=""!(Y="???")
SET AMHVFILE="V POV"
SET AMHBN="VFILE"
DO E8
QUIT
+3 SET X=$PIECE(^AMHSITE(DUZ(2),11,Y,0),U,2)
+4 IF X=""
SET AMHVFILE="V POV"
SET AMHBN="VFILE"
DO E8
QUIT
+5 ;NO PCC LINK AT ALL
IF X=1
QUIT
+6 DO @X
+7 QUIT
2 ;-- pass standard narrative and code
+1 ;S APCDALVR("APCDTPOV")=$S($P(^AMHSITE(DUZ(2),0),U,13)]"":$P(^ICD9($P(^AMHSITE(DUZ(2),0),U,13),0),U),1:"V65.40") ;replace with standard code
+2 IF $TEXT(ICDDX^ICDEX)]""
Begin DoDot:1
+3 ;replace with standard code
IF AMHIMP=1
SET APCDALVR("APCDTPOV")=$SELECT($PIECE(^AMHSITE(DUZ(2),0),U,13)]"":$PIECE($$ICDDX^ICDEX($PIECE(^AMHSITE(DUZ(2),0),U,13)),U,2),1:"V65.40")
+4 IF AMHIMP=30
SET APCDALVR("APCDTPOV")=$SELECT($PIECE($GET(^AMHSITE(DUZ(2),12)),U,4)]"":$PIECE($$ICDDX^ICDEX($PIECE(^AMHSITE(DUZ(2),12),U,4)),U,2),1:"Z71.9")
End DoDot:1
IF 1
+5 IF '$TEST
Begin DoDot:1
+6 ;replace with standard code
IF AMHIMP=1
SET APCDALVR("APCDTPOV")=$SELECT($PIECE(^AMHSITE(DUZ(2),0),U,13)]"":$PIECE($$ICDDX^ICDCODE($PIECE(^AMHSITE(DUZ(2),0),U,13)),U,2),1:"V65.40")
+7 IF AMHIMP=30
SET APCDALVR("APCDTPOV")=$SELECT($PIECE($GET(^AMHSITE(DUZ(2),12)),U,4)]"":$PIECE($$ICDDX^ICDCODE($PIECE(^AMHSITE(DUZ(2),12),U,4)),U,2),1:"Z71.9")
End DoDot:1
+8 ;replace
IF AMHPTYPE="M"
SET APCDALVR("APCDTNQ")=$SELECT($$MHNARR^AMHLEIN(DUZ(2))]"":$$MHNARR^AMHLEIN(DUZ(2)),1:"MENTAL HEALTH")
QUIT
+9 ;replace
IF AMHPTYPE="S"
SET APCDALVR("APCDTNQ")=$SELECT($$SSNARR^AMHLEIN(DUZ(2))]"":$$SSNARR^AMHLEIN(DUZ(2)),1:"SOCIAL SERVICE VISIT")
QUIT
+10 ;replace
IF AMHPTYPE="C"
SET APCDALVR("APCDTNQ")=$SELECT($$CDNARR^AMHLEIN(DUZ(2))]"":$$CDNARR^AMHLEIN(DUZ(2)),1:"CHEMICAL DEPENDENCY VISIT")
QUIT
+11 ;replace
IF AMHPTYPE="O"
SET APCDALVR("APCDTNQ")=$SELECT($$OTNARR^AMHLEIN(DUZ(2))]"":$$OTNARR^AMHLEIN(DUZ(2)),1:"BEHAVIOR HEALTH VISIT")
QUIT
+12 SET APCDALVR("APCDTNQ")="BEHAVIORAL HEALTH VISIT"
+13 QUIT
+14 ;
3 ;crosswalk (mask some stuff, no other)
+1 SET APCDALVR("APCDTPOV")=$PIECE(^AMHPROB(AMHPOVP,0),U,5)
+2 IF '$PIECE(^AMHPROB(AMHPOVP,0),U,8)
SET APCDALVR("APCDTNQ")="`"_$PIECE(^AMHRPRO(AMHX,0),U,4)
+3 KILL AMHERR
IF $PIECE(^AMHPROB(AMHPOVP,0),U,8)
Begin DoDot:1
+4 ;S X=$P(^AMHPROB(AMHPOVP,0),U,5),Y=$O(^ICD9("AB",X,"")) ;CSV
+5 ;CSV
SET X=$PIECE(^AMHPROB(AMHPOVP,0),U,5)
SET Y=+$$CODEN^ICDCODE(X,80)
+6 IF Y=""!(Y=-1)
SET AMHBN="VFILE"
SET AMHVFILE="V POV"
DO E2
SET AMHERR=1
QUIT
+7 IF $TEXT(ICDDX^ICDEX)=""
SET APCDALVR("APCDTNQ")=$EXTRACT($PIECE($$ICDDX^ICDCODE(Y,$PIECE($PIECE(^AMHREC(AMHR,0),U),".")),U,4),1,79)
+8 IF $TEXT(ICDDX^ICDEX)]""
SET APCDALVR("APCDTNQ")=$EXTRACT($PIECE($$ICDDX^ICDEX(Y,$PIECE($PIECE(^AMHREC(AMHR,0),U),".")),U,4),1,79)
+9 IF $PIECE(^AMHPROB(AMHPOVP,0),U,9)
SET APCDALVR("APCDTNQ")=$EXTRACT(APCDALVR("APCDTNQ"),1,42)_" SEE "_$EXTRACT($$PPNAME^AMHUTIL(AMHR),1,18)_" FOR DETAILS"
+10 IF $PIECE(^AMHPROB(AMHPOVP,0),U,11)
SET APCDALVR("APCDTNQ")="DIAGNOSTIC IMPRESSION: "_$EXTRACT(APCDALVR("APCDTNQ"),1,55)
+11 IF $PIECE(^AMHPROB(AMHPOVP,0),U,12)
SET APCDALVR("APCDTNQ")=$EXTRACT($PIECE(^AMHPROB(AMHPOVP,0),U,2),1,35)_" - "_$EXTRACT($$GET1^DIQ(9002011.01,AMHX,.04),1,40)
End DoDot:1
IF $DATA(AMHERR)
QUIT
+12 QUIT
+13 ;
4 ;
+1 IF AMHIMP=1
SET APCDALVR("APCDTPOV")=$PIECE(^AMHPROB(AMHPOVP,0),U,5)
+2 IF AMHIMP=30
SET APCDALVR("APCDTPOV")=$PIECE(^AMHPROB(AMHPOVP,0),U,17)
+3 SET APCDALVR("APCDTNQ")="`"_$PIECE(^AMHRPRO(AMHX,0),U,4)
+4 QUIT
5 ;
+1 IF AMHIMP=1
SET APCDALVR("APCDTPOV")=$PIECE(^AMHPROB(AMHPOVP,0),U,5)
+2 IF AMHIMP=30
SET APCDALVR("APCDTPOV")=$PIECE(^AMHPROB(AMHPOVP,0),U,17)
+3 ;replace
IF AMHPTYPE="M"
SET APCDALVR("APCDTNQ")=$SELECT($$MHNARR^AMHLEIN(DUZ(2))]"":$$MHNARR^AMHLEIN(DUZ(2)),1:"MENTAL HEALTH")
QUIT
+4 ;replace
IF AMHPTYPE="S"
SET APCDALVR("APCDTNQ")=$SELECT($$SSNARR^AMHLEIN(DUZ(2))]"":$$SSNARR^AMHLEIN(DUZ(2)),1:"SOCIAL SERVICE VISIT")
QUIT
+5 ;replace
IF AMHPTYPE="C"
SET APCDALVR("APCDTNQ")=$SELECT($$CDNARR^AMHLEIN(DUZ(2))]"":$$CDNARR^AMHLEIN(DUZ(2)),1:"CHEMICAL DEPENDENCY VISIT")
QUIT
+6 ;replace
IF AMHPTYPE="O"
SET APCDALVR("APCDTNQ")=$SELECT($$OTNARR^AMHLEIN(DUZ(2))]"":$$OTNARR^AMHLEIN(DUZ(2)),1:"BEHAVIOR HEALTH VISIT")
QUIT
+7 SET APCDALVR("APCDTNQ")="BEHAVIORAL HEALTH VISIT"
+8 QUIT
V2 SET AMHERROR="inability to create visit"
GOTO LBULL
V3 SET AMHERROR="invalid visit parameters (date, location etc.)"
GOTO LBULL
+1 ;
E1 SET AMHERROR="incorrect template specification"
GOTO LBULL
E2 SET AMHERROR="invalid values being passed to "_AMHVFILE
GOTO LBULL
E8 SET AMHERROR="Provider specific link not complete in site file "_$$PPNAME^AMHUTIL(AMHR)
GOTO LBULL
E9 SET AMHERROR="Could not resolve file 200-file 6 pointer for V PROVIDER. "_$PIECE(^VA(200,X,0),U)
GOTO LBULL
+1 ;
LBULL ;
+1 KILL XMB
+2 SET XMDUZ="BEHAVIORAL HEALTH"
+3 ;,AMHDUZ=DUZ,DUZ=.5
SET XMB(1)=AMHR
SET XMB(2)=$PIECE(^DPT($PIECE(AMHR0,U,8),0),U)_" (DFN "_$PIECE(AMHR0,U,8)_")"
SET Y=$PIECE(AMHR0,U)
DO DD^%DT
SET XMB(3)=Y
SET XMB(4)=AMHERROR
SET XMB(5)=$GET(AMHVFILE)
SET XMB="AMH PCC LINK FAIL "_AMHBN
+4 DO ^XMB
KILL XMB,AMHERROR,AMHBN,AMHVFILE,XMDUZ
+5 QUIT
