ADEAPC1.m

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