Routine: ADEAPC

ADEAPC ;IHS/HQW/MJL - DENTAL PCC LINK  [ 08/26/2008  7:16 AM ]

 ;;6.0;ADE;**12,16,20**;APRIL 1999;Build 16

 ;IHS/SET/HMW 20050414 Rewrote this routine to call BSDAPI

 ;IHS/CMI/LAB 20080826 Added interactive PCC Link

 ;------->INITIALIZE

 Q:'$D(^ADEPARAM(+^AUTTSITE(1,0),0))  ;Q:$P(^(0),U,5)'="y"  ;IHS/SET/HMW 2-6-2003 **12** PCC Link mandatory

 K APCDALVR

 S AUPNTALK=1,APCDANE=1,APCDAUTO=1

 S APCDALVR("APCDDATE")=$P(^ADEPCD(ADEDFN,0),U,2) S APCDALVR("APCDLOC")="`"_$P(^(0),U,3)

 S APCDALVR("APCDPAT")=ADEPAT

 S APCDALVR("APCDCLN")=$O(^DIC(40.7,"C",56,0))

 S:APCDALVR("APCDCLN") APCDALVR("APCDCLN")="`"_APCDALVR("APCDCLN")

 S APCDALVR("APCDACS")=""

 S APCDALVR("APCDTYPE")="I"

 S ADEAPC("ADELOC")=$P(APCDALVR("APCDLOC"),"`",2)

 S ADEAPC("ADELOC")=$O(^ADEPARAM(+^AUTTSITE(1,0),1,"B",ADEAPC("ADELOC"),0))

 S ADEAPC("ADETYP")=""

 I ADEAPC("ADELOC")]"",$D(^ADEPARAM(+^AUTTSITE(1,0),1,ADEAPC("ADELOC"),0)) S ADEAPC("ADETYP")=$P(^ADEPARAM(+^AUTTSITE(1,0),1,ADEAPC("ADELOC"),0),U,3)

 I ADEAPC("ADETYP")]"" S APCDALVR("APCDTYPE")=ADEAPC("ADETYP")

 K ADEAPC("ADELOC"),ADEAPC("ADETYP")

 ;------->IF CONTRACT VISIT SET APPROPRIATE APC VARIABLES

 D CONTRACT

 ;------->CREATE VISIT OR APPEND TO EXISTING

 D DSERV

 I 'ADENEWVS D

 . Q:'$D(^ADEPCD(ADEDFN,"PCC"))

 . D ^ADEAPC2

 . D VMOD

 . D ^ADEAPC1

 E  D

 . N ADEV,ADEADD

 . S ADEV=0,ADEADD=""

 . D VISIT(.ADEV,.ADEADD)

 . I '+ADEV D BULLT Q

 . ;/IHS/OIT/GAB 10.27.15 COMMENT BELOW FOR ICD10, VISIT WILL GO TO THE PCC CODING QUEUE TO CHANGE THE "ZZZ.999" UNCODED DIAGNOSIS BEFORE IT GOES TO BILLING

 . ;D REV(ADEV) ;IHS/OIT/HMW 9-22-2005 **16**Mark visit as reviewed

 . S APCDALVR("APCDVSIT")=ADEV

 . I ADEADD="ADD" D

 . . ;MAKE POV, PRV AND VDEN ENTRIES

 . . N ADEV

 . . D ^ADEAPC1

 . E  D

 . . ;APPENDING TO EXISTING VISIT SO MAKE VDEN ENTRIES

 . . N ADEW,XMB,ADEHIT

 . . S ADEHIT=0

 . . D DENTRY^ADEAPC1

 . . D:$D(ADEW) DENTRY3^ADEAPC1

 . . D:$D(XMB) BULLT^ADEAPC1

 . . ;modify any existing primary provider on the visit to be secondary

 . . ;unless it's the same as the ADE-entered provider

 . . I $D(^AUPNVPRV("AD",ADEV)) D

 . . . N ADEVPRV,APCDALVR,DA,DIE,ADEPRV,ADEDA

 . . . S ADEPRV=$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 ADEDA=0 F  S ADEDA=$O(^AUPNVPRV("AD",ADEV,ADEDA)) Q:'+ADEDA  D

 . . . . N DA

 . . . . S DA=ADEDA

 . . . . Q:'$D(^AUPNVPRV(DA,0))

 . . . . Q:$P(^AUPNVPRV(DA,0),U,4)'="P"

 . . . . I $P(^AUPNVPRV(DA,0),U)=ADEPRV S ADEHIT=1 Q  ;If prim provider is ADE provider, do nothing

 . . . . S DIE=9000010.06

 . . . . S DR=".04////S" ;otherwise, make it secondary

 . . . . D ^DIE,MOD^AUPNVSIT

 . . . Q

 . . ;Add the ADE-entered dental provider as the primary, unless it was already there

 . . I 'ADEHIT D VPRV^ADEAPC1

 . . ;Add a VPOV entry if none already exists on the visit.

 . . I '$D(^AUPNVPOV("AD",ADEV)) D VPOV^ADEAPC1

 . . Q

 . D ADDPCC^ADEAPC2("301///"_ADEV,ADEDFN)

. Q

 ;------->END

END K APCDALVR,ADEOP,ADEADA,ADEQTY,ADEI,ADEC,ADESER,ADEX,ADEV,ADEY,Y,XMB

 K ADETSUR

 K ADETFEE ;IHS/SET/HMW 2-6-2003 **12**

REV(ADEV) ;IHS/OIT/HMW 9-22-2005 **16**Mark visit as reviewed

 N ADEFDA,ADEIEN,ADEMSG

 S ADEFDA(9000010,ADEV_",",1111)="R"

 D UPDATE^DIE(,"ADEFDA","ADEIEN","ADEMSG")

VISIT(ADEV,ADEADD) ;

 N ADEBSD,ADEBSOUT,ADEHIT

 S ADEV=0,ADEADD="",ADEHIT=0

 ;If GETVISIT API not installed, call APCDALV directly and add a new visit

 I $T(GETVISIT^APCDAPI4)="" D  Q

 . D EN^APCDALV

 . I $D(APCDALVR("APCDAFLG")) S ADEV=0 Q

 . S ADEV=APCDALVR("APCDVSIT")

 . S ADEADD="ADD"

. Q

 S ADEBSD("PAT")=ADEPAT

 S ADEBSD("VISIT DATE")=APCDALVR("APCDDATE")

 S ADEBSD("SITE")=$P(APCDALVR("APCDLOC"),"`",2)

 S ADEBSD("VISIT TYPE")=APCDALVR("APCDTYPE")

 S ADEBSD("SRV CAT")="A"

 S ADEBSD("TIME RANGE")=-1

 S ADEBSD("CLINIC CODE")=$P(APCDALVR("APCDCLN"),"`",2)

 S ADEBSD("USR")=$G(DUZ)

 N APCDALVR

 D GETVISIT^APCDAPI4(.ADEBSD,.ADEBSOUT)

 ;IHS/CMI/LAB - added line below to allow a site to have an interactive pcc link

 I $P($G(^ADEPARAM(+^AUTTSITE(1,0),0)),U,11) D INTERACT Q

 ;IHS/CMI/LAB - end mods

 S ADEV=0 F  S ADEV=$O(ADEBSOUT(ADEV)) Q:'+ADEV  D  Q:ADEHIT

 . I ADEBSOUT(ADEV)="ADD" S ADEHIT=1,ADEADD="ADD" Q

 . ;SKIP IF VISIT HAS EXISTING V DENTAL ENTRIES

 . Q:$D(^AUPNVDEN("AD",ADEV))

 . ;VISIT MATCHES AND HAS NO V DENTAL ENTRIES, SO USE IT

 . S ADEHIT=1,ADEADD="" Q

 ;IF NONE OF THE RETURNED VISITS WORKED, THEN FORCE AN ADD

 I '+ADEV D

 . S ADEBSD("FORCE ADD")=1

 . D GETVISIT^APCDAPI4(.ADEBSD,.ADEBSOUT)

 . Q:'+ADEBSOUT(0)

 . S ADEV=$O(ADEBSOUT(0))

 . S ADEADD="ADD"

VMOD S APCDALVR("APCDATMP")="[APCDALVR 9000010 (MOD)]" D EN^APCDALVR

 I $D(APCDALVR("APCDAFLG")) S XMB(7)="PCC VISIT"

DSERV S ADESER=0

 F ADEI=1:1 S ADESER=$O(^ADEPCD(ADEDFN,"ADA",ADESER)),ADEC=ADEI-1 Q:'+ADESER  D

 . N ADENOD

 . S ADENOD=^ADEPCD(ADEDFN,"ADA",ADESER,0)

 . Q:$P($G(^AUTTADA($P(ADENOD,U),0)),U,7)=1  ;IHS/SET/HMW 4-13-2005 **16**

 . S ADEADA(ADEI)=$P(ADENOD,U)

 . S ADEQTY(ADEI)=1

 . S ADEOP(ADEI)=$P(ADENOD,U,2)

 . S ADETFEE(ADEI)=$P(ADENOD,U,3) ;IHS/SET/HMW 2-6-2003 **12**

 . S ADETSUR(ADEI)=$P(ADENOD,U,4)

 ;F ADEI=1:1:ADEC S:$P(^AUTTADA(ADEADA(ADEI),0),U,7)=1 Y=0 ;IHS/OIT/HMW 4-13-2005 **16**

CONTRACT ;IHS/SET/HMW 2-6-2003 Modified this subroutine to append ` to APCDALVR("APCDCLN")

 I ADECON D

 . S APCDALVR("APCDTYPE")="CONTRACT"

 . S APCDALVR("APCDCLN")=$O(^DIC(40.7,"C",99,""))

 . S:APCDALVR("APCDCLN") APCDALVR("APCDCLN")="`"_APCDALVR("APCDCLN")

 . S APCDALVR("APCDTNQ")="CONTRACT DENTAL/ORAL HEALTH VISIT"

BULLT S %DT="",X="T" D ^%DT X ^DD("DD")

 S XMB(1)=$P(^DPT(ADEPAT,0),U,1)_" Patient DFN= "_ADEPAT,XMB(2)=Y,XMB(6)="A PCC visit could not be created for this patient",XMB="ADEVISIT" S XMDUZ=.5 D ^XMB

INTERACT ;

 ;IHS/CMI/LAB - interactive pcc link

 ;first, if 1 visit passed back and it was an add use it and quit

 I $P(ADEBSOUT(0),U)=1 S V=$O(ADEBSOUT(0)) I ADEBSOUT(V)="ADD" S ADEV=V,ADEHIT=1,ADEADD="ADD" Q

 ;since more than one passed back display them to the user and quit

SELECT ; SELECT EXISTING VISIT

 NEW ADEV1,ADEC,ADEA,ADEX,ADEA,ADEB,ADEVLT,ADEVLOC

 S ADEV=""

 W !!,"PATIENT: ",$P(^DPT(ADEPAT,0),U)," has one or more VISITs on this date.",!,"If one of these is your visit, please select it",!

 K ADEV1 S (ADEC,ADEA,ADEX)="",ADEV1=0 F  S ADEV1=$O(ADEBSOUT(ADEV1)) Q:ADEV1'=+ADEV1  S ADEX=$G(^AUPNVSIT(ADEV1,0)),ADEX11=$G(^AUPNVSIT(ADEV1,11)) D WRITE

 S ADEC=ADEC+1 W !,ADEC,"  Create New Visit",!

 K DIR

 S DIR(0)="N^1:"_ADEC,DIR("A")="Select" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) S ADEBSD("FORCE ADD")=1 D BSDADD1 Q

 I ADEC=Y S ADEBSD("FORCE ADD")=1 D BSDADD1 Q

 S ADEV=ADEX1(Y)

WRITE ; WRITE VISITS FOR SELECT

 S ADEC=ADEC+1,ADEX1(ADEC)=ADEV1

 S ADEVLT=$P(+ADEX,".",2),ADEVLT=$S(ADEVLT="":"<NONE>",$L(ADEVLT)=1:ADEVLT_"0:00 ",1:$E(ADEVLT,1,2)_":"_$E(ADEVLT,3,4)_$E("00",1,2-$L($E(ADEVLT,3,4)))_" ")

 S ADEVLOC=""

 I $P(ADEX,U,6),$D(^AUTTLOC($P(ADEX,U,6),0)) S ADEVLOC=$P(^(0),U,7),ADEVLOC=ADEVLOC_$E("    ",1,4-$L(ADEVLOC))

 S:ADEVLOC="" ADEVLOC="...."

 W !,ADEC,"  TIME: ",ADEVLT,"LOC: ",ADEVLOC," TYPE: ",$P(ADEX,U,3)," CAT: ",$P(ADEX,U,7)," CLINIC: ",$S($P(ADEX,U,8)]"":$E($P(^DIC(40.7,$P(ADEX,U,8),0),U),1,8),1:"<NONE>") D

 .W ?57,"DEC: ",$S($P(ADEX,U,9):$P(ADEX,U,9),1:0),$S($P(ADEX11,U,3)]"":" VCN:"_$P(ADEX11,U,3),1:"")

 .I $P(ADEX,U,22) W !?3,"Hospital Location: ",$P($G(^SC($P(ADEX,U,22),0)),U)

 .S ADETIU=$$PRIMPROV^APCLV(ADEV1,"N") I ADETIU]"" W !?3,"Provider on Visit: ",ADETIU

 .S ADEA=0,ADEB="" F  S ADEA=$O(^AUPNVDEN("AD",ADEV1,ADEA)) Q:ADEA'=+ADEA  S ADEB=ADEB_$$VAL^XBDIQ1(9000010.05,ADEA,.01)_" ; "

 .I ADEB]"" W !?3,"Dental ADA Codes:  ",ADEB

BSDADD1 ;

 ;IF NONE OF THE RETURNED VISITS WORKED, THEN FORCE AN ADD

 I '+ADEV D

 . S ADEBSD("FORCE ADD")=1

 . D GETVISIT^APCDAPI4(.ADEBSD,.ADEBSOUT)

 . Q:'+ADEBSOUT(0)

 . S ADEV=$O(ADEBSOUT(0))

 . S ADEADD="ADD"

ADEAPC    ;IHS/HQW/MJL - DENTAL PCC LINK  [ 08/26/2008  7:16 AM ]

 +1       ;;6.0;ADE;**12,16,20**;APRIL 1999;Build 16

 +2       ;IHS/SET/HMW 20050414 Rewrote this routine to call BSDAPI

 +3       ;IHS/CMI/LAB 20080826 Added interactive PCC Link

 +4       ;

 +5       ;------->INITIALIZE

 +6       ;Q:$P(^(0),U,5)'="y"  ;IHS/SET/HMW 2-6-2003 **12** PCC Link mandatory

           IF '$DATA(^ADEPARAM(+^AUTTSITE(1,0),0))

               QUIT

 +7        KILL APCDALVR

 +8        SET AUPNTALK=1

           SET APCDANE=1

           SET APCDAUTO=1

 +9        SET APCDALVR("APCDDATE")=$PIECE(^ADEPCD(ADEDFN,0),U,2)

           SET APCDALVR("APCDLOC")="`"_$PIECE(^(0),U,3)

 +10       SET APCDALVR("APCDPAT")=ADEPAT

 +11       SET APCDALVR("APCDCLN")=$ORDER(^DIC(40.7,"C",56,0))

 +12       IF APCDALVR("APCDCLN")

               SET APCDALVR("APCDCLN")="`"_APCDALVR("APCDCLN")

 +13       SET APCDALVR("APCDACS")=""

 +14       SET APCDALVR("APCDTYPE")="I"

 +15       SET ADEAPC("ADELOC")=$PIECE(APCDALVR("APCDLOC"),"`",2)

 +16       SET ADEAPC("ADELOC")=$ORDER(^ADEPARAM(+^AUTTSITE(1,0),1,"B",ADEAPC("ADELOC"),0))

 +17       SET ADEAPC("ADETYP")=""

 +18       IF ADEAPC("ADELOC")]""

               IF $DATA(^ADEPARAM(+^AUTTSITE(1,0),1,ADEAPC("ADELOC"),0))

                   SET ADEAPC("ADETYP")=$PIECE(^ADEPARAM(+^AUTTSITE(1,0),1,ADEAPC("ADELOC"),0),U,3)

 +19       IF ADEAPC("ADETYP")]""

               SET APCDALVR("APCDTYPE")=ADEAPC("ADETYP")

 +20       KILL ADEAPC("ADELOC"),ADEAPC("ADETYP")

 +21      ;------->IF CONTRACT VISIT SET APPROPRIATE APC VARIABLES

 +22       DO CONTRACT

 +23      ;------->CREATE VISIT OR APPEND TO EXISTING

 +24       DO DSERV

 +25       IF 'ADENEWVS

               Begin DoDot:1

 +26               IF '$DATA(^ADEPCD(ADEDFN,"PCC"))

                       QUIT

 +27               DO ^ADEAPC2

 +28               DO VMOD

 +29               DO ^ADEAPC1

               End DoDot:1

 +30      IF '$TEST

               Begin DoDot:1

 +31               NEW ADEV,ADEADD

 +32               SET ADEV=0

                   SET ADEADD=""

 +33               DO VISIT(.ADEV,.ADEADD)

 +34               IF '+ADEV

                       DO BULLT

                       QUIT

 +35      ;/IHS/OIT/GAB 10.27.15 COMMENT BELOW FOR ICD10, VISIT WILL GO TO THE PCC CODING QUEUE TO CHANGE THE "ZZZ.999" UNCODED DIAGNOSIS BEFORE IT GOES TO BILLING

 +36      ;D REV(ADEV) ;IHS/OIT/HMW 9-22-2005 **16**Mark visit as reviewed

 +37               SET APCDALVR("APCDVSIT")=ADEV

 +38               IF ADEADD="ADD"

                       Begin DoDot:2

 +39      ;MAKE POV, PRV AND VDEN ENTRIES

 +40                       NEW ADEV

 +41                       DO ^ADEAPC1

                       End DoDot:2

 +42              IF '$TEST

                       Begin DoDot:2

 +43      ;APPENDING TO EXISTING VISIT SO MAKE VDEN ENTRIES

 +44                       NEW ADEW,XMB,ADEHIT

 +45                       SET ADEHIT=0

 +46                       DO DENTRY^ADEAPC1

 +47                       IF $DATA(ADEW)

                               DO DENTRY3^ADEAPC1

 +48                       IF $DATA(XMB)

                               DO BULLT^ADEAPC1

 +49      ;modify any existing primary provider on the visit to be secondary

 +50      ;unless it's the same as the ADE-entered provider

 +51                       IF $DATA(^AUPNVPRV("AD",ADEV))

                               Begin DoDot:3

 +52                               NEW ADEVPRV,APCDALVR,DA,DIE,ADEPRV,ADEDA

 +53                               SET ADEPRV=$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"))

 +54                               SET ADEDA=0

FOR

                                       SET ADEDA=$ORDER(^AUPNVPRV("AD",ADEV,ADEDA))

                                       IF '+ADEDA

                                           QUIT

                                       Begin DoDot:4

 +55                                       NEW DA

 +56                                       SET DA=ADEDA

 +57                                       IF '$DATA(^AUPNVPRV(DA,0))

                                               QUIT

 +58                                       IF $PIECE(^AUPNVPRV(DA,0),U,4)'="P"

                                               QUIT

 +59      ;If prim provider is ADE provider, do nothing

                                           IF $PIECE(^AUPNVPRV(DA,0),U)=ADEPRV

                                               SET ADEHIT=1

                                               QUIT

 +60                                       SET DIE=9000010.06

 +61      ;otherwise, make it secondary

                                           SET DR=".04////S"

 +62                                       DO ^DIE

                                           DO MOD^AUPNVSIT

                                       End DoDot:4

 +63                               QUIT

                               End DoDot:3

 +64      ;Add the ADE-entered dental provider as the primary, unless it was already there

 +65                       IF 'ADEHIT

                               DO VPRV^ADEAPC1

 +66      ;Add a VPOV entry if none already exists on the visit.

 +67                       IF '$DATA(^AUPNVPOV("AD",ADEV))

                               DO VPOV^ADEAPC1

 +68                       QUIT

                       End DoDot:2

 +69               DO ADDPCC^ADEAPC2("301///"_ADEV,ADEDFN)

 +70               QUIT

               End DoDot:1

 +71      ;

 +72      ;------->END

END        KILL APCDALVR,ADEOP,ADEADA,ADEQTY,ADEI,ADEC,ADESER,ADEX,ADEV,ADEY,Y,XMB

 +1        KILL ADETSUR

 +2       ;IHS/SET/HMW 2-6-2003 **12**

           KILL ADETFEE

 +3        QUIT

 +4       ;

REV(ADEV) ;IHS/OIT/HMW 9-22-2005 **16**Mark visit as reviewed

 +1        NEW ADEFDA,ADEIEN,ADEMSG

 +2        SET ADEFDA(9000010,ADEV_",",1111)="R"

 +3        DO UPDATE^DIE(,"ADEFDA","ADEIEN","ADEMSG")

 +4        QUIT

 +5       ;

VISIT(ADEV,ADEADD) ;

 +1       ;

 +2        NEW ADEBSD,ADEBSOUT,ADEHIT

 +3        SET ADEV=0

           SET ADEADD=""

           SET ADEHIT=0

 +4       ;

 +5       ;If GETVISIT API not installed, call APCDALV directly and add a new visit

 +6        IF $TEXT(GETVISIT^APCDAPI4)=""

               Begin DoDot:1

 +7                DO EN^APCDALV

 +8                IF $DATA(APCDALVR("APCDAFLG"))

                       SET ADEV=0

                       QUIT

 +9                SET ADEV=APCDALVR("APCDVSIT")

 +10               SET ADEADD="ADD"

 +11               QUIT

               End DoDot:1

               QUIT

 +12      ;

 +13       SET ADEBSD("PAT")=ADEPAT

 +14       SET ADEBSD("VISIT DATE")=APCDALVR("APCDDATE")

 +15       SET ADEBSD("SITE")=$PIECE(APCDALVR("APCDLOC"),"`",2)

 +16       SET ADEBSD("VISIT TYPE")=APCDALVR("APCDTYPE")

 +17       SET ADEBSD("SRV CAT")="A"

 +18       SET ADEBSD("TIME RANGE")=-1

 +19       SET ADEBSD("CLINIC CODE")=$PIECE(APCDALVR("APCDCLN"),"`",2)

 +20       SET ADEBSD("USR")=$GET(DUZ)

 +21       NEW APCDALVR

 +22       DO GETVISIT^APCDAPI4(.ADEBSD,.ADEBSOUT)

 +23      ;

 +24      ;IHS/CMI/LAB - added line below to allow a site to have an interactive pcc link

 +25       IF $PIECE($GET(^ADEPARAM(+^AUTTSITE(1,0),0)),U,11)

               DO INTERACT

               QUIT

 +26      ;IHS/CMI/LAB - end mods

 +27      ;

 +28       SET ADEV=0

FOR

               SET ADEV=$ORDER(ADEBSOUT(ADEV))

               IF '+ADEV

                   QUIT

               Begin DoDot:1

 +29               IF ADEBSOUT(ADEV)="ADD"

                       SET ADEHIT=1

                       SET ADEADD="ADD"

                       QUIT

 +30      ;SKIP IF VISIT HAS EXISTING V DENTAL ENTRIES

 +31               IF $DATA(^AUPNVDEN("AD",ADEV))

                       QUIT

 +32      ;VISIT MATCHES AND HAS NO V DENTAL ENTRIES, SO USE IT

 +33               SET ADEHIT=1

                   SET ADEADD=""

                   QUIT

               End DoDot:1

               IF ADEHIT

                   QUIT

 +34      ;

 +35      ;IF NONE OF THE RETURNED VISITS WORKED, THEN FORCE AN ADD

 +36       IF '+ADEV

               Begin DoDot:1

 +37               SET ADEBSD("FORCE ADD")=1

 +38               DO GETVISIT^APCDAPI4(.ADEBSD,.ADEBSOUT)

 +39               IF '+ADEBSOUT(0)

                       QUIT

 +40               SET ADEV=$ORDER(ADEBSOUT(0))

 +41               SET ADEADD="ADD"

               End DoDot:1

 +42      ;

 +43       QUIT

 +44      ;

VMOD       SET APCDALVR("APCDATMP")="[APCDALVR 9000010 (MOD)]"

           DO EN^APCDALVR

 +1        IF $DATA(APCDALVR("APCDAFLG"))

               SET XMB(7)="PCC VISIT"

 +2        QUIT

DSERV      SET ADESER=0

 +1        FOR ADEI=1:1

               SET ADESER=$ORDER(^ADEPCD(ADEDFN,"ADA",ADESER))

               SET ADEC=ADEI-1

               IF '+ADESER

                   QUIT

               Begin DoDot:1

 +2                NEW ADENOD

 +3                SET ADENOD=^ADEPCD(ADEDFN,"ADA",ADESER,0)

 +4       ;IHS/SET/HMW 4-13-2005 **16**

                   IF $PIECE($GET(^AUTTADA($PIECE(ADENOD,U),0)),U,7)=1

                       QUIT

 +5                SET ADEADA(ADEI)=$PIECE(ADENOD,U)

 +6                SET ADEQTY(ADEI)=1

 +7                SET ADEOP(ADEI)=$PIECE(ADENOD,U,2)

 +8       ;IHS/SET/HMW 2-6-2003 **12**

                   SET ADETFEE(ADEI)=$PIECE(ADENOD,U,3)

 +9                SET ADETSUR(ADEI)=$PIECE(ADENOD,U,4)

               End DoDot:1

 +10      ;F ADEI=1:1:ADEC S:$P(^AUTTADA(ADEADA(ADEI),0),U,7)=1 Y=0 ;IHS/OIT/HMW 4-13-2005 **16**

 +11       QUIT

CONTRACT  ;IHS/SET/HMW 2-6-2003 Modified this subroutine to append ` to APCDALVR("APCDCLN")

 +1        IF ADECON

               Begin DoDot:1

 +2                SET APCDALVR("APCDTYPE")="CONTRACT"

 +3                SET APCDALVR("APCDCLN")=$ORDER(^DIC(40.7,"C",99,""))

 +4                IF APCDALVR("APCDCLN")

                       SET APCDALVR("APCDCLN")="`"_APCDALVR("APCDCLN")

 +5                SET APCDALVR("APCDTNQ")="CONTRACT DENTAL/ORAL HEALTH VISIT"

               End DoDot:1

 +6        QUIT

BULLT      SET %DT=""

           SET X="T"

           DO ^%DT

           XECUTE ^DD("DD")

 +1        SET XMB(1)=$PIECE(^DPT(ADEPAT,0),U,1)_" Patient DFN= "_ADEPAT

           SET XMB(2)=Y

           SET XMB(6)="A PCC visit could not be created for this patient"

           SET XMB="ADEVISIT"

           SET XMDUZ=.5

           DO ^XMB

 +2        QUIT

 +3       ;

INTERACT  ;

 +1       ;IHS/CMI/LAB - interactive pcc link

 +2       ;first, if 1 visit passed back and it was an add use it and quit

 +3        IF $PIECE(ADEBSOUT(0),U)=1

               SET V=$ORDER(ADEBSOUT(0))

               IF ADEBSOUT(V)="ADD"

                   SET ADEV=V

                   SET ADEHIT=1

                   SET ADEADD="ADD"

                   QUIT

 +4       ;since more than one passed back display them to the user and quit

SELECT    ; SELECT EXISTING VISIT

 +1        NEW ADEV1,ADEC,ADEA,ADEX,ADEA,ADEB,ADEVLT,ADEVLOC

 +2        SET ADEV=""

 +3        WRITE !!,"PATIENT: ",$PIECE(^DPT(ADEPAT,0),U)," has one or more VISITs on this date.",!,"If one of these is your visit, please select it",!

 +4        KILL ADEV1

           SET (ADEC,ADEA,ADEX)=""

           SET ADEV1=0

FOR

               SET ADEV1=$ORDER(ADEBSOUT(ADEV1))

               IF ADEV1'=+ADEV1

                   QUIT

               SET ADEX=$GET(^AUPNVSIT(ADEV1,0))

               SET ADEX11=$GET(^AUPNVSIT(ADEV1,11))

               DO WRITE

 +5        SET ADEC=ADEC+1

           WRITE !,ADEC,"  Create New Visit",!

 +6        KILL DIR

 +7        SET DIR(0)="N^1:"_ADEC

           SET DIR("A")="Select"

           KILL DA

           DO ^DIR

           KILL DIR

 +8        IF $DATA(DIRUT)

               SET ADEBSD("FORCE ADD")=1

               DO BSDADD1

               QUIT

 +9        IF ADEC=Y

               SET ADEBSD("FORCE ADD")=1

               DO BSDADD1

               QUIT

 +10       SET ADEV=ADEX1(Y)

 +11       QUIT

 +12      ;

WRITE     ; WRITE VISITS FOR SELECT

 +1        SET ADEC=ADEC+1

           SET ADEX1(ADEC)=ADEV1

 +2        SET ADEVLT=$PIECE(+ADEX,".",2)

           SET ADEVLT=$SELECT(ADEVLT="":"<NONE>",$LENGTH(ADEVLT)=1:ADEVLT_"0:00 ",1:$EXTRACT(ADEVLT,1,2)_":"_$EXTRACT(ADEVLT,3,4)_$EXTRACT("00",1,2-$LENGTH($EXTRACT(ADEVLT,3,4)))_" ")

 +3        SET ADEVLOC=""

 +4        IF $PIECE(ADEX,U,6)

               IF $DATA(^AUTTLOC($PIECE(ADEX,U,6),0))

                   SET ADEVLOC=$PIECE(^(0),U,7)

                   SET ADEVLOC=ADEVLOC_$EXTRACT("    ",1,4-$LENGTH(ADEVLOC))

 +5        IF ADEVLOC=""

               SET ADEVLOC="...."

 +6        WRITE !,ADEC,"  TIME: ",ADEVLT,"LOC: ",ADEVLOC," TYPE: ",$PIECE(ADEX,U,3)," CAT: ",$PIECE(ADEX,U,7)," CLINIC: ",$SELECT($PIECE(ADEX,U,8)]"":$EXTRACT($PIECE(^DIC(40.7,$PIECE(ADEX,U,8),0),U),1,8),1:"<NONE>")

           Begin DoDot:1

 +7            WRITE ?57,"DEC: ",$SELECT($PIECE(ADEX,U,9):$PIECE(ADEX,U,9),1:0),$SELECT($PIECE(ADEX11,U,3)]"":" VCN:"_$PIECE(ADEX11,U,3),1:"")

 +8            IF $PIECE(ADEX,U,22)

                   WRITE !?3,"Hospital Location: ",$PIECE($GET(^SC($PIECE(ADEX,U,22),0)),U)

 +9            SET ADETIU=$$PRIMPROV^APCLV(ADEV1,"N")

               IF ADETIU]""

                   WRITE !?3,"Provider on Visit: ",ADETIU

 +10           SET ADEA=0

               SET ADEB=""

FOR

                   SET ADEA=$ORDER(^AUPNVDEN("AD",ADEV1,ADEA))

                   IF ADEA'=+ADEA

                       QUIT

                   SET ADEB=ADEB_$$VAL^XBDIQ1(9000010.05,ADEA,.01)_" ; "

 +11           IF ADEB]""

                   WRITE !?3,"Dental ADA Codes:  ",ADEB

           End DoDot:1

 +12       QUIT

 +13      ;

BSDADD1   ;

 +1       ;IF NONE OF THE RETURNED VISITS WORKED, THEN FORCE AN ADD

 +2        IF '+ADEV

               Begin DoDot:1

 +3                SET ADEBSD("FORCE ADD")=1

 +4                DO GETVISIT^APCDAPI4(.ADEBSD,.ADEBSOUT)

 +5                IF '+ADEBSOUT(0)

                       QUIT

 +6                SET ADEV=$ORDER(ADEBSOUT(0))

 +7                SET ADEADD="ADD"

               End DoDot:1

 +8       ;

 +9        QUIT

ADEAPC.m