ADEAPC1 ; IHS/HQT/MJL - DENTAL PCC LINK PART 2 ; [ 04/02/2014 8:12 AM ]
;;6.0;ADE;**2,12,16,27**;March 25,1999;Build 14
;;IHS/OIT/GAB 6.4.14 Modified for ICD10 - PATCH 27
;;IHS/OIT/GAB 7.2015 Modified for ICD10 Maint. - PATCH 28
;------->CREATE NARRATIVE AND POV
D VPOV
;------->V PROVIDER
D VPRV
;------->V DENTAL
D DENTRY D:$D(ADEW) DENTRY3
;------->SEND BULLETIN IF PROBLEMS
D BULLT:$D(XMB)
;------->END
K APCDALVR,ADEOP,ADEADA,ADEQTY,ADEI,ADEC,ADESER,ADEX,ADEFLG,ADEV,Y,XMB,ADECODE,ADEW,ADEVDFN
Q
VPOV ;EPFIC
I $P(^ADEPCD(ADEDFN,0),U,7)]"" S APCDALVR("APCDTNQ")=$P(^(0),U,7)
E S:'$D(APCDALVR("APCDTNQ")) APCDALVR("APCDTNQ")="DENTAL/ORAL HEALTH VISIT"
S APCDALVR("APCDOVRR")=1
;/IHS/OIT/GAB 9.4.14 CHANGED BELOW FOR ICD10 PATCH 27
;S APCDALVR("APCDTPOV")="V72.2" S APCDALVR("APCDATMP")="[APCDALVR 9000010.07 (ADD)]" D EN^APCDALVR
S APCDALVR("APCDTPOV")="V72.2"
;/IHS/OIT/GAB *** BEGIN PATCH 28 *****
S VISDT=$P(APCDALVR("APCDDATE"),".")
S I=$$IMP^ADEAPC1(VISDT)
I I=30 S APCDALVR("APCDTPOV")="ZZZ.999"
;I (APCDALVR("APCDDATE"))>I10DATE S APCDALVR("APCDTPOV")="ZZZ.999"
;/IHS/OIT/GAB END ICD10 CHANGES
S APCDALVR("APCDATMP")="[APCDALVR 9000010.07 (ADD)]" D EN^APCDALVR
K APCDOVRR,APCDALVR("APCDOVRR")
I $D(APCDALVR("APCDAFLG")) S XMB(3)="V POV" Q
S ADEVDFN=APCDALVR("APCDADFN")
D ADDPCC^ADEAPC2("302///"_ADEVDFN,ADEDFN)
Q
VPRV ;EP
;*IHS/HMW Uncomment next 8 lines and comment 9th line to implement
;VA200 changes
;N ADEDTPRO
;S ADEDTPRO=$P(^ADEPCD(ADEDFN,0),U,4)
;I '$D(^DIC(16,ADEDTPRO,"A3")) S XMB(4)="V PROVIDER" Q
;S ADEDTPRO=^DIC(16,ADEDTPRO,"A3")
;S APCDALVR("APCDTPRO")="`"_ADEDTPRO
;S APCDALVR("APCDTPS")="P"
;S APCDALVR("APCDATMP")="[APCDALVR 9000010.06 (ADD)]"
;D EN^APCDALVR
;TUC/DIR/MJL 9/2/99
S APCDALVR("APCDTPRO")="`"_$S($P(^DD(9000010.06,.01,0),U,2)["P6":$P(^ADEPCD(ADEDFN,0),U,4),1:^DIC(16,$P(^ADEPCD(ADEDFN,0),U,4),"A3"))
S APCDALVR("APCDTPS")="P",APCDALVR("APCDATMP")="[APCDALVR 9000010.06 (ADD)]" D EN^APCDALVR
I $D(APCDALVR("APCDAFLG")) S XMB(4)="V PROVIDER" Q
S ADEVDFN=APCDALVR("APCDADFN")
D ADDPCC^ADEAPC2("303///"_ADEVDFN,ADEDFN)
Q
DENTRY ;EP IHS/SET/HMW **16** Added EP to permit external call
S ADEH=1
F ADEI=1:1:ADEC D
. S APCDALVR("APCDTSC")="`"_ADEADA(ADEI)
. S APCDALVR("APCDTNOU")=ADEQTY(ADEI)
. S:ADEOP(ADEI)]"" APCDALVR("APCDTOS")="`"_ADEOP(ADEI)
. S:ADETSUR(ADEI)]"" APCDALVR("APCDTSUR")=ADETSUR(ADEI)
. S APCDALVR("APCDATMP")="[APCDALVR 9000010.05 (ADD)]"
. S APCDALVR("APCDTFEE")=$G(ADETFEE(ADEI)) ;IHS/SET/HMW **12** pass fee to PCC
. D EN^APCDALVR
. K APCDALVR("APCDTOS")
. K APCDALVR("APCDTSUR")
. D DENTRY2
I '$D(ADEAPC) K ADEH,ADEG Q
I +ADEAPC(1) D ADDPCC^ADEAPC2("304///"_ADEAPC(1),ADEDFN)
I $D(ADEAPC(2)) D ADDPCC^ADEAPC2("401///"_ADEAPC(2),ADEDFN)
I $D(ADEAPC(3)) D ADDPCC^ADEAPC2("501///"_ADEAPC(3),ADEDFN)
K ADEH,ADEG,ADEQ,ADEAPC Q
DENTRY2 I $D(APCDALVR("APCDAFLG")) S ADEW=ADEI,ADECODE(ADEW)=$P(^AUTTADA(ADEADA(ADEI),0),U,1) Q
S ADEVDFN=APCDALVR("APCDADFN")
I $D(ADEAPC(ADEH)) S ADEAPC(ADEH)=ADEAPC(ADEH)_"|"_ADEVDFN S:$L(ADEAPC(ADEH))>180 ADEH=ADEH+1 Q
S ADEAPC(ADEH)=ADEVDFN
Q
DENTRY3 ;EP IHS/SET/HMW **16** Added EP to permit external call
S ADEW="" F ADEL=0:0 S ADEW=$O(ADECODE(ADEW)) Q:ADEW="" S $P(XMB(5)," ",ADEW)=ADECODE(ADEW)
Q
BULLT ;EP IHS/SET/HMW **16** Added EP to permit external call
S Y=$P(^ADEPCD(ADEDFN,0),U,2) X ^DD("DD")
S XMB(1)=$P(^DPT(ADEPAT,0),U)_" Patient DFN= "_ADEPAT,XMB(2)=Y,XMB(6)=APCDALVR("APCDVSIT"),XMB="ADEDENTAL" S XMDUZ=.5 S:'ADENEWVS XMB(8)="***THIS DATA FOR A VISIT BEING MODIFIED***"
D ^XMB
Q
IMP(D) ; which coding system should be used
;/IHS/OIT/GAB ADDED THIS FUNCTION FOR ICD10 PATCH #28
;RETURN IEN of entry in ^ICDS
;1 = ICD9
;30 = ICD10
;
I $G(D)="" S D=DT
NEW X,Y,IMPDT
I '$O(^ICDS("F",80,0)) Q 1
S Y=""
S X=0 F S X=$O(^ICDS("F",80,X)) Q:X'=+X D
.I $P(^ICDS(X,0),U,4)="" Q ;NO IMPLEMENTATION DATE
.S IMPDT=$P(^ICDS(X,0),U,4)
;Compare the visit date to ensure it should use ICD10
I D>(IMPDT-1) S Y=30
E S Y=1
Q Y
ADEAPC1 ; IHS/HQT/MJL - DENTAL PCC LINK PART 2 ; [ 04/02/2014 8:12 AM ]
+1 ;;6.0;ADE;**2,12,16,27**;March 25,1999;Build 14
+2 ;;IHS/OIT/GAB 6.4.14 Modified for ICD10 - PATCH 27
+3 ;;IHS/OIT/GAB 7.2015 Modified for ICD10 Maint. - PATCH 28
+4 ;------->CREATE NARRATIVE AND POV
+5 DO VPOV
+6 ;------->V PROVIDER
+7 DO VPRV
+8 ;------->V DENTAL
+9 DO DENTRY
IF $DATA(ADEW)
DO DENTRY3
+10 ;------->SEND BULLETIN IF PROBLEMS
+11 IF $DATA(XMB)
DO BULLT
+12 ;------->END
+13 KILL APCDALVR,ADEOP,ADEADA,ADEQTY,ADEI,ADEC,ADESER,ADEX,ADEFLG,ADEV,Y,XMB,ADECODE,ADEW,ADEVDFN
+14 QUIT
VPOV ;EPFIC
+1 IF $PIECE(^ADEPCD(ADEDFN,0),U,7)]""
SET APCDALVR("APCDTNQ")=$PIECE(^(0),U,7)
+2 IF '$TEST
IF '$DATA(APCDALVR("APCDTNQ"))
SET APCDALVR("APCDTNQ")="DENTAL/ORAL HEALTH VISIT"
+3 SET APCDALVR("APCDOVRR")=1
+4 ;/IHS/OIT/GAB 9.4.14 CHANGED BELOW FOR ICD10 PATCH 27
+5 ;S APCDALVR("APCDTPOV")="V72.2" S APCDALVR("APCDATMP")="[APCDALVR 9000010.07 (ADD)]" D EN^APCDALVR
+6 SET APCDALVR("APCDTPOV")="V72.2"
+7 ;/IHS/OIT/GAB *** BEGIN PATCH 28 *****
+8 SET VISDT=$PIECE(APCDALVR("APCDDATE"),".")
+9 SET I=$$IMP^ADEAPC1(VISDT)
+10 IF I=30
SET APCDALVR("APCDTPOV")="ZZZ.999"
+11 ;I (APCDALVR("APCDDATE"))>I10DATE S APCDALVR("APCDTPOV")="ZZZ.999"
+12 ;/IHS/OIT/GAB END ICD10 CHANGES
+13 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.07 (ADD)]"
DO EN^APCDALVR
+14 KILL APCDOVRR,APCDALVR("APCDOVRR")
+15 IF $DATA(APCDALVR("APCDAFLG"))
SET XMB(3)="V POV"
QUIT
+16 SET ADEVDFN=APCDALVR("APCDADFN")
+17 DO ADDPCC^ADEAPC2("302///"_ADEVDFN,ADEDFN)
+18 QUIT
VPRV ;EP
+1 ;*IHS/HMW Uncomment next 8 lines and comment 9th line to implement
+2 ;VA200 changes
+3 ;N ADEDTPRO
+4 ;S ADEDTPRO=$P(^ADEPCD(ADEDFN,0),U,4)
+5 ;I '$D(^DIC(16,ADEDTPRO,"A3")) S XMB(4)="V PROVIDER" Q
+6 ;S ADEDTPRO=^DIC(16,ADEDTPRO,"A3")
+7 ;S APCDALVR("APCDTPRO")="`"_ADEDTPRO
+8 ;S APCDALVR("APCDTPS")="P"
+9 ;S APCDALVR("APCDATMP")="[APCDALVR 9000010.06 (ADD)]"
+10 ;D EN^APCDALVR
+11 ;TUC/DIR/MJL 9/2/99
+12 SET APCDALVR("APCDTPRO")="`"_$SELECT($PIECE(^DD(9000010.06,.01,0),U,2)["P6":$PIECE(^ADEPCD(ADEDFN,0),U,4),1:^DIC(16,$PIECE(^ADEPCD(ADEDFN,0),U,4),"A3"))
+13 SET APCDALVR("APCDTPS")="P"
SET APCDALVR("APCDATMP")="[APCDALVR 9000010.06 (ADD)]"
DO EN^APCDALVR
+14 IF $DATA(APCDALVR("APCDAFLG"))
SET XMB(4)="V PROVIDER"
QUIT
+15 SET ADEVDFN=APCDALVR("APCDADFN")
+16 DO ADDPCC^ADEAPC2("303///"_ADEVDFN,ADEDFN)
+17 QUIT
DENTRY ;EP IHS/SET/HMW **16** Added EP to permit external call
+1 SET ADEH=1
+2 FOR ADEI=1:1:ADEC
Begin DoDot:1
+3 SET APCDALVR("APCDTSC")="`"_ADEADA(ADEI)
+4 SET APCDALVR("APCDTNOU")=ADEQTY(ADEI)
+5 IF ADEOP(ADEI)]""
SET APCDALVR("APCDTOS")="`"_ADEOP(ADEI)
+6 IF ADETSUR(ADEI)]""
SET APCDALVR("APCDTSUR")=ADETSUR(ADEI)
+7 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.05 (ADD)]"
+8 ;IHS/SET/HMW **12** pass fee to PCC
SET APCDALVR("APCDTFEE")=$GET(ADETFEE(ADEI))
+9 DO EN^APCDALVR
+10 KILL APCDALVR("APCDTOS")
+11 KILL APCDALVR("APCDTSUR")
+12 DO DENTRY2
End DoDot:1
+13 IF '$DATA(ADEAPC)
KILL ADEH,ADEG
QUIT
+14 IF +ADEAPC(1)
DO ADDPCC^ADEAPC2("304///"_ADEAPC(1),ADEDFN)
+15 IF $DATA(ADEAPC(2))
DO ADDPCC^ADEAPC2("401///"_ADEAPC(2),ADEDFN)
+16 IF $DATA(ADEAPC(3))
DO ADDPCC^ADEAPC2("501///"_ADEAPC(3),ADEDFN)
+17 KILL ADEH,ADEG,ADEQ,ADEAPC
QUIT
DENTRY2 IF $DATA(APCDALVR("APCDAFLG"))
SET ADEW=ADEI
SET ADECODE(ADEW)=$PIECE(^AUTTADA(ADEADA(ADEI),0),U,1)
QUIT
+1 SET ADEVDFN=APCDALVR("APCDADFN")
+2 IF $DATA(ADEAPC(ADEH))
SET ADEAPC(ADEH)=ADEAPC(ADEH)_"|"_ADEVDFN
IF $LENGTH(ADEAPC(ADEH))>180
SET ADEH=ADEH+1
QUIT
+3 SET ADEAPC(ADEH)=ADEVDFN
+4 QUIT
DENTRY3 ;EP IHS/SET/HMW **16** Added EP to permit external call
+1 SET ADEW=""
FOR ADEL=0:0
SET ADEW=$ORDER(ADECODE(ADEW))
IF ADEW=""
QUIT
SET $PIECE(XMB(5)," ",ADEW)=ADECODE(ADEW)
+2 QUIT
BULLT ;EP IHS/SET/HMW **16** Added EP to permit external call
+1 SET Y=$PIECE(^ADEPCD(ADEDFN,0),U,2)
XECUTE ^DD("DD")
+2 SET XMB(1)=$PIECE(^DPT(ADEPAT,0),U)_" Patient DFN= "_ADEPAT
SET XMB(2)=Y
SET XMB(6)=APCDALVR("APCDVSIT")
SET XMB="ADEDENTAL"
SET XMDUZ=.5
IF 'ADENEWVS
SET XMB(8)="***THIS DATA FOR A VISIT BEING MODIFIED***"
+3 DO ^XMB
+4 QUIT
IMP(D) ; which coding system should be used
+1 ;/IHS/OIT/GAB ADDED THIS FUNCTION FOR ICD10 PATCH #28
+2 ;RETURN IEN of entry in ^ICDS
+3 ;1 = ICD9
+4 ;30 = ICD10
+5 ;
+6 IF $GET(D)=""
SET D=DT
+7 NEW X,Y,IMPDT
+8 IF '$ORDER(^ICDS("F",80,0))
QUIT 1
+9 SET Y=""
+10 SET X=0
FOR
SET X=$ORDER(^ICDS("F",80,X))
IF X'=+X
QUIT
Begin DoDot:1
+11 ;NO IMPLEMENTATION DATE
IF $PIECE(^ICDS(X,0),U,4)=""
QUIT
+12 SET IMPDT=$PIECE(^ICDS(X,0),U,4)
End DoDot:1
+13 ;Compare the visit date to ensure it should use ICD10
+14 IF D>(IMPDT-1)
SET Y=30
+15 IF '$TEST
SET Y=1
+16 QUIT Y
