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**
Q
;
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")
Q
;
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"
;
Q
;
VMOD S APCDALVR("APCDATMP")="[APCDALVR 9000010 (MOD)]" D EN^APCDALVR
I $D(APCDALVR("APCDAFLG")) S XMB(7)="PCC VISIT"
Q
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**
Q
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"
Q
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
Q
;
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)
Q
;
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
Q
;
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"
;
Q
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
