BADEHL4 ;IHS/MSC/MGH/VAC - Dentrix HL7 inbound interface ;01-Oct-2010 ;MGH
;;1.0;DENTAL/EDR INTERFACE;**1,4,5*;FEB 22, 2010;Build 23
;; Modified - IHS/MSC/AMF - 11/23/10 - More descriptive alert messages
;; Modified - IHS/MSC/AMF 10/2010 fix for hospital location FT1-16,2
;; Modified - IHS/OIT/GAB **4** 05/2015 for ICD10 Implementation
;; Modified - IHS/OIT/GAB **5** 03/2016 for ICD10 to accept POV from Dentrix (v 8.0.5 or later)
UPD ;EP Update a V Dental entry
N DIEN,MATCH,DA,APCDVSIT,CODEIEN,APCDSUR,APCDTEE
N TYPE,TCODE,SCODE,PROV,X,Y,Y2,PIEN,POVIEN2,ADACODE,VTIME
N NOOPSITE
S APCDALVR("APCDPAT")=DFN ;patient
;visit stored in V Dental file
S APCDVSIT=$P($G(^AUPNVDEN(EXKEY,0)),U,3)
;Added patient name, DFN, and Visit date. can't add ASUFAC or HLBIEN
I '$D(^AUPNVSIT(APCDVSIT)) D ACK^BADEHL3(HLMSGIEN,DFN,"Can't update visit "_APCDVSIT_". Not in RPMS:") Q ;IHS/MSC/AMF 11/23/10 More descriptive alert
S APCDALVR("APCDVSIT")=APCDVSIT
;ADA code stored in V Dental file
S APCDTSC=$P($G(^AUPNVDEN(EXKEY,0)),U,1)
S ADACODE=$P($G(^AUTTADA(APCDTSC,0)),U,1)
S NOOPSITE=$$GET1^DIQ(9999999.31,APCDTSC,.09,"I")="n"
;See if the provider was changed
S PROV=$$GET^HLOPRS(.SEGFT1,20,1)
I PROV="" D ACK^BADEHL3(HLMSGIEN,DFN,"Missing provider in FT1:") Q ;IHS/MSC/AMF 11/23/10 More descriptive alert
D CHECKPRV(PROV)
S APCDALVR("APCDACS")=""
S TYPE=$$GET^HLOPRS(.SEGFT1,6)
;Check the date/time in the message
S X=$$GET^HLOPRS(.SEGFT1,4)
I X="" D ACK^BADEHL3(HLMSGIEN,DFN,"Missing visit date in FT1:") Q ;IHS/MSC/AMF 11/23/10 More descriptive alert
I $L(X)=8 D
.S VTIME=$$GET^XPAR("ALL","BADE EDR DEFAULT TIME")
.I VTIME="" S VTIME=1138 ;IHS/MSC/AMF 10/2010 Change in default time
.S X=X_VTIME
S Y=$$FMDATE^HLFNC(X)
S VISDT=$P(Y,".") ;/IHS/OIT/GAB CHECK FOR CODING SYSTEM TO USE **4**
S Y2=$P($G(^AUPNVDEN(EXKEY,12)),U,1)
;If the date and time of the visit is different, the old procedure
;and possibly the visit must be deleted and everything restarted
I Y'=Y2 D DEL,NEW^BADEHL3 Q
;ADA code in the message
S TCODE=$$GET^HLOPRS(.SEGFT1,7)
I TCODE="" D ACK^BADEHL3(HLMSGIEN,DFN,"Missing ADA code in FT1:") Q ;IHS/MSC/AMF 11/23/10 More descriptive alert
I $E(TCODE,1,1)="D" S SCODE=$E(TCODE,2,$L(TCODE))
E S SCODE=TCODE
S CODEIEN=$O(^AUTTADA("B",SCODE,""))
S APCDALVR("APCDTSC")="`"_CODEIEN
;Check to see if the code has changed. If the code was changed,
;the old code needs to be deleted and a new one stored
I CODEIEN'=APCDTSC D DELV,SETUP,ADD
I SCODE=ADACODE D DELV,SETUP,ADD
Q
SETUP ;Setup the variables needed to modifiy or add
N SURGDES
S APCDALVR("AUPNTALK")=""
S APCDALVR("APCDANE")=""
;number of units
S APCDALVR("APCDTNOU")=1
;Tooth surface
S APCDTSUR=$$GET^HLOPRS(.SEGFT1,26,4)
S APCDALVR("APCDTSUR")=APCDTSUR
;Fee for procedure
S APCDTFEE=$$GET^HLOPRS(.SEGFT1,11)
S APCDALVR("APCDTFEE")=APCDTFEE
;Date/Time
S X=$$GET^HLOPRS(.SEGFT1,4)
I X="" D ACK^BADEHL3(HLMSGIEN,DFN,"Missing visit date in FT1:") Q ;IHS/MSC/AMF 11/23/10 More descriptive alert
I $L(X)=8 D
.S VTIME=$$GET^XPAR("ALL","BADE EDR DEFAULT TIME")
.I VTIME="" S VTIME=1138
.S X=X_VTIME
S Y=$$FMDATE^HLFNC(X)
S VISDT=$P(Y,".") ;/IHS/OIT/GAB CHECK FOR CODING SYSTEM TO USE **4**
D DD^%DT S APCDTCDT=Y ;External format
S APCDALVR("APCDTCDT")=APCDTCDT
S APCDALVR("APCDTCLN")="DENTAL"
S APCDALVR("APCDTEXK")=APCDTEXK
;Provider
S PNAME=$P($G(^VA(200,PROV,0)),U,1)
S APCDALVR("APCDTEPR")=PNAME
S APCDALVR("APCDTPRV")=PNAME
S MOD=$$GET^HLOPRS(.SEGFT1,26,1) ; Operative Site Code (may contain text)
S SURGDES=$$GET^HLOPRS(.SEGFT1,26,2) ;Operative Site Descriptive Text
S APCDTOS=$S(NOOPSITE:"",1:$$GETTOS(MOD,SURGDES))
I 'NOOPSITE,'APCDTOS D ACK^BADEHL3(HLMSGIEN,DFN,"No valid ADA code in FT1:") Q ;IHS/MSC/AMF 11/23/10 More descriptive alert
S:APCDTOS APCDALVR("APCDTOS")="`"_APCDTOS
; ----- IHS/MSC/AMF 10/2010 fix for FT1-16,2
;Find the location and clinic location
S ASUFAC2=$$GET^HLOPRS(.SEGFT1,16,1)
S HOSLOC=$$GET^HLOPRS(.SEGFT1,16,2)
I $L(ASUFAC2),'$L(HOSLOC) S ASUFAC=ASUFAC2
;
S BADEWARN=""
I $L(HOSLOC) D
.S PARLOC=+$O(^SC("B",HOSLOC,"")) I 'PARLOC S BADEWARN="Warning: Clinic "_HOSLOC_" is not valid ",HOSLOC="" Q
.S LOC=+$P($G(^SC(PARLOC,0)),U,4) I 'LOC S BADEWARN="Warning: Location not found for Clinic "_HOSLOC_" ",HOSLOC=""
I '$L(HOSLOC) D
.S LOC=$O(^AUTTLOC("C",ASUFAC,"")) I '$L(LOC) S BADERR="No location associated ASUFAC "_ASUFAC_":" Q
.S PARLOC=+$$GET^XPAR("DIV.`"_LOC_"^SYS","BADE EDR DEFAULT CLINIC") I 'PARLOC S BADERR=" There is no default clinic for this location " Q
.S LOCA=+$P($G(^SC(PARLOC,0)),U,4) I LOCA'=LOC S BADERR=" The LOCATION associated with this ASUFAC and BADE EDR DEFAULT CLINIC is incorrect " Q
I $L(BADERR) D ACK^BADEHL3(HLMSGIEN,DFN,BADERR) Q ;IHS/MSC/AMF 11/23/10 More descriptive alert
I $L(BADEWARN) D ACK^BADEHL3(HLMSGIEN,DFN,BADEWARN) ;IHS/MSC/AMF 11/23/10 More descriptive alert
;location
;S ASUFAC=$$GET^HLOPRS(.SEGFT1,16,1)
;S HOSLOC=$$GET^HLOPRS(.SEGFT1,16,2)
;I ASUFAC="" D ACK^BADEHL3(HLMSGIEN,DFN,"Missing location in FT1:") Q ;IHS/MSC/AMF 11/23/10 More descriptive alert
;S (LOC,PARLOC)=""
;S LOC=$O(^AUTTLOC("C",ASUFAC,LOC))
;Get the clinic location
;I HOSLOC="" D
.;S PARLOC=+$$GET^XPAR("DIV.`"_LOC_"^SYS","BADE EDR DEFAULT CLINIC")
;E D
.;S PARLOC=+$O(^SC("B",HOSLOC,PARLOC))
;I 'PARLOC S BADERR=" Clinic does not exist in RPMS in msg: "_$P($G(^DPT(DFN,0)),"^",1)_" "_DFN_" "_ASUFAC_" "_MIEN D ACK^BADEHL3(BADERR) Q ;IHS/MSC/VAC 10/2010
;I LOC'=$P($G(^SC(PARLOC,0)),U,4) S BADERR=" Clinic "_HOSLOC_" isn't defined for ASUFAC location "_$P($G(^DPT(DFN,0)),"^",1)_" "_DFN_" "_ASUFAC D ACK^BADEHL3(BADERR) Q ;IHS/MSC/VAC 10/2010
;
; ----- end IHS/MSC/AMF 10/2010 fix for FT1-16,2
S APCDALVR("APCDLOC")="`"_LOC
;External key
S APCDALVR("APCDTEXK")=APCDTEXK
Q
MOD S APCDALVR("APCDATMP")="[APCDALVR 9000010.05 (ADD)]"
D EN^APCDALVR
Q
ADD S APCDALVR("APCDATMP")="[APCDALVR 9000010.05 (ADD)]"
D EN^APCDALVR
Q
DELV S FILE=9000010.05
D VDEL(FILE,EXKEY,APCDVSIT)
Q
DEL ;EP Delete V file entry
;Find the entry in the V DENTAL file and the visit
N MATCH,DIEN,VSIT,DIK,DA,POV,PRV,DCNT,TEXK,DCNT2
N APCDALVR
S DIEN=EXKEY
S TEXK=APCDTEXK
;Delete the entry
I '$D(^AUPNVDEN(DIEN)) D ACK^BADEHL3(HLMSGIEN,DFN,"Can't delete visit "_DIEN_". Not in RPMS:") Q ;IHS/MSC/AMF 11/23/10 More descriptive alert
S VSIT=$P($G(^AUPNVDEN(+DIEN,0)),U,3)
S PROV=$$GET^HLOPRS(.SEGFT1,20,1)
I PROV="" D ACK^BADEHL3(HLMSGIEN,DFN,"Missing provider in FT1:") Q ;IHS/MSC/AMF 11/23/10 More descriptive alert
;Get the dependent count for this visit
S DCNT=$P(^AUPNVSIT(VSIT,0),U,9)
;Delete this entry and quit
;I DCNT>3 D ;/IHS/OIT/GAB 3/2016 **5** commented this line
S FILE=9000010.05
D VDEL(FILE,DIEN,VSIT)
S FILE=9000010.07
D POVDEL(FILE,TEXK,VSIT) ;/IHS/OIT/GAB 3/2016 **5** DELETE POV AFTER PROCEDURE IS REMOVED
I DCNT<2 D PROVDEL(VSIT,PROV) ;/IHS/OIT/GAB 3/2016 **5** REMOVE PROVIDER ENTRY IF ONE ENTRY LEFT
;If its 3, delete the VPOV and VPRV entries then delete the visit
;I DCNT<4 D ;/IHS/OIT/GAB **5** COMMENTED NEXT 4 LINES-REPLACED WITH ABOVE
;.S FILE=9000010.05
;.D VDEL(FILE,DIEN,VSIT)
;.D CHECK(VSIT,PROV)
;Delete visit if dependent count is 0
I DCNT=0 D VSTDEL(VSIT)
Q
VDEL(FILE,IEN,VSIT) ;Delete a V-file entry
N X,DIK,DA
S DIK=FILE,DA=IEN
S X=$$DEL^APCDALVR(DIK,DA)
I X>0 D ACK^BADEHL3(HLMSGIEN,DFN,"Can't delete V file entry:") Q ;IHS/MSC/AMF 11/23/10 More descriptive alert
Q
VSTDEL(VSIT) ;Delete the visit with zero dependents
N APCDVDLT,U,APCDVFLE,AUPNVSIT,APCDVNM,APCDVDG,APCDVIGR,APCDVDFN
N APCDVI,DIK,DA
S APCDVDLT=VSIT
D EN^APCDVDLT
Q
CHECK(VSIT,PROV) ;Remove the POV and PRV if those are the 2 remaining dependent entries
N POVIEN,MATCH,ICD,VPRV,PROVIEN,ICDIEN,PROV2,PROVIEN2
;IHS/OIT/GAB **4** ADDED BELOW 7 LINES
S ICD=""
S I=$$IMP^BADEHL3(VISDT) ;/IHS/OIT/GAB **4** CK FOR WHICH CODING SYSTEM TO USE
;IHS/OIT/GAB **4** IF I=30 USING ICD10, IF I=1 USING ICD9
I I=30 D
.S ICD=$O(^ICD9("AB","ZZZ.999",ICD))
.I ICD="" S ICD=$O(^ICD9("AB","ZZZ.999 ",ICD))
I I=1 D
.I ICD="" S ICD=$O(^ICD9("AB","V72.2",ICD))
.S:'ICD ICD=$O(^ICD9("AB","V72.2 ",ICD))
Q:ICD=""
;First the POV
S MATCH=0
S POVIEN="" F S POVIEN=$O(^AUPNVPOV("AD",VSIT,POVIEN)) Q:POVIEN=""!(MATCH=1) D
.S POVIEN2=$P($G(^AUPNVPOV(POVIEN,0)),U,1)
.I ICD=POVIEN2 S ICDIEN=POVIEN S MATCH=1
Q:MATCH=0
;Found the POV for this visit so delete the dependent entry
I MATCH=1 D
.S FILE=9000010.07
.D VDEL(FILE,ICDIEN,VSIT)
;Next the provider
S (VPRV,MATCH)=0
S PROVIEN="" F S PROVIEN=$O(^AUPNVPRV("AD",VSIT,PROVIEN)) Q:PROVIEN=""!(MATCH=1) D
.S PROV2=$P($G(^AUPNVPRV(PROVIEN,0)),U,1)
.I PROV=PROV2 S PROVIEN2=PROVIEN S MATCH=1
Q:MATCH=0
I MATCH=1 D
.S FILE=9000010.06
.D VDEL(FILE,PROVIEN2,VSIT)
;Recheck the dependent count
S DCNT=$P(^AUPNVSIT(VSIT,0),U,9)
Q
CHECKPRV(PROV) ;See if the provider in the message is new
N VPRV,DPRV,MATCH,PRVIEN,IEN,PPRV,PRIM ;IHS/MSC/MGH 7/2010 new var PRIM for patch 1
S MATCH=0,PRIM="P" ;IHS/MSC/MGH 7/2010 new var PRIM for patch 1
;Find the provider in the existing V dental file
S DPRV=$P($G(^AUPNVDEN(EXKEY,12)),U,2)
;If its the same provider quit
Q:DPRV=PROV
;If its not the same provider, check the visit to see if the new provider
;is already on this visit
S VPRV="" F S VPRV=$O(^AUPNVPRV("AD",APCDVSIT,VPRV)) Q:VPRV="" D
.;IHS/MSC/MGH patch 1 check for primary
.I $P($G(^AUPNVPRV(VPRV,0)),U,4)="P" S PRIM="S"
.S PRVIEN=$P($G(^AUPNVPRV(VPRV,0)),U,1)
.I PROV=PRVIEN S MATCH=1
;If this new provider is already attached to this visit we are OK
Q:MATCH=1
;If the new provider is not on this visit,add this provider
I MATCH=0 D PRV^BADEHL3(PRIM) ;patch 1 IHS/MSC/MGH
;Now we need to see if we need to delete the old provider.
;If this provider does not have any procedures attached we will delete
S MATCH=0
S IEN="" F S IEN=$O(^AUPNVDEN("AD",APCDVSIT,IEN)) Q:IEN=""!(MATCH=1) D
.S PPRV=$P($G(^AUPNVDEN(IEN,12)),U,2)
.I PPRV=DPRV&(IEN'=EXKEY) S MATCH=1
;This provider is on other procedures
Q:MATCH=1
I MATCH=0 D
.N PP,FDA ;IHS/MSC/MGH patch 1 check for primary
.S PP=0 ;IHS/MSC/MGH patch 1 check for primary
.S PIEN="" F S PIEN=$O(^AUPNVPRV("AD",APCDVSIT,PIEN)) Q:PIEN="" D
..S PROVIEN=$P($G(^AUPNVPRV(PIEN,0)),U,1)
..;IHS/MSC/MGH patch 1 check for primary
..I $P($G(^AUPNVPRV(PIEN,0)),U,4)="P" S PP=1 ; IHS/MSC/MGH patch 1 We are deleting the primary provider
..I PROVIEN=DPRV D
...S FILE=9000010.06
...D VDEL(FILE,PIEN,APCDVSIT)
...;ISH/MSC/MGH PATCH 1 If primary provider was deleted, make the new provider primary
...I PP=1 D
....S PIEN="" F S IEN=$O(^AUPNVPRV("AD",APCDVSIT,PIEN)) Q:PIEN="" D
.....S PROVIEN=$P($G(^AUPNVPRV(PIEN,0)),U,1)
.....I PROVIEN=PROV D
......S FDA=9000010.06
......S FDA=$NA(FDA(FNUM,PIEN_","))
......S @FDA@(.04)="P"
......K FDA
; ----- end ISH/MSC/MGH PATCH 1 If primary provider was deleted
Q
; Returns Dental Operative Code IEN
GETTOS(CODE,DESC) ;EP
Q:'$L(DESC) 0
N RET,LP
S RET=0
I $L(DESC)>30 D ;"B" only contains first 30 characters
.S LP=0 F S LP=$O(^ADEOPS(LP)) Q:'LP D Q:RET
..S:$P(^ADEOPS(LP,0),U)=DESC RET=LP
E D
.S RET=+$O(^ADEOPS("B",DESC,0))
Q RET
POVDEL(FILE,IEN,VSIT) ;/IHS/OIT/GAB **5** ADDED THIS SEGMENT TO CHECK THE POV ENTRIES & DELETE
N EKEY,MATCH,VPRV,PROVIEN,PROV2,PROVIEN2
S ICDIEN="",POVIEN="",POVIEN2="",KEY="",ICD=""
S EKEY=IEN ;SET THE EXTERNAL KEY
S I=$$IMP^BADEHL3(VISDT) ;WHICH CODING SYSTEM TO USE ICD9=1 OR ICD10=30
I I=30 D
.S POVIEN=$O(^AUPNVPOV("AD",VSIT,POVIEN))
.Q:POVIEN=""
.S KEY=$P($G(^AUPNVPOV(POVIEN,12)),U,9) ; set the external key
.I KEY D
..S POVIEN="" F S POVIEN=$O(^AUPNVPOV("AD",VSIT,POVIEN)) Q:POVIEN="" D
...S KEY=$P($G(^AUPNVPOV(POVIEN,12)),U,9)
...I KEY=EKEY D
....S ICDIEN=$P($G(^AUPNVPOV(POVIEN,0)),U,1)
....I ICDIEN D
.....S FILE=9000010.07
.....S ICDIEN=POVIEN
.....D VDEL(FILE,ICDIEN,VSIT)
.E D ;/IHS/OIT/GAB **5** NO EXTERNAL KEY SO SET TO ZZZ.999
..S ICD=$O(^ICD9("AB","ZZZ.999",ICD))
..I ICD="" S ICD=$O(^ICD9("AB","ZZZ.999 ",ICD))
..Q:ICD=""
..S MATCH=0
..S POVIEN="" F S POVIEN=$O(^AUPNVPOV("AD",VSIT,POVIEN)) Q:POVIEN=""!(MATCH=1) D
...S POVIEN2=$P($G(^AUPNVPOV(POVIEN,0)),U,1)
...I ICD=POVIEN2 S ICDIEN=POVIEN S MATCH=1
..Q:MATCH=0
..I MATCH=1 D ;Found the POV for this visit so delete the dependent entry
...S FILE=9000010.07
...D VDEL(FILE,ICDIEN,VSIT)
I I=1 D ;/IHS/OIT/GAB **5** IF NOT ICD10 REMOVE V72.2
.S ICD=$O(^ICD9("AB","V72.2",ICD))
.S:'ICD ICD=$O(^ICD9("AB","V72.2 ",ICD))
.Q:ICD=""
.S MATCH=0 ;find the POV
.S POVIEN="" F S POVIEN=$O(^AUPNVPOV("AD",VSIT,POVIEN)) Q:POVIEN=""!(MATCH=1) D
..S POVIEN2=$P($G(^AUPNVPOV(POVIEN,0)),U,1)
..I ICD=POVIEN2 S ICDIEN=POVIEN S MATCH=1
.Q:MATCH=0
.I MATCH=1 D ;found the match so remove the POV
..S FILE=9000010.07
..D VDEL(FILE,ICDIEN,VSIT)
S DCNT=$P(^AUPNVSIT(VSIT,0),U,9)
Q
PROVDEL(VSIT,PROV) ;/IHS/OIT/GAB ADDED TO REMOVE PROVIDER ENTRY
N MATCH,VPRV,PROVIEN,PROV2,PROVIEN2
S (VPRV,MATCH)=0
S PROVIEN="" F S PROVIEN=$O(^AUPNVPRV("AD",VSIT,PROVIEN)) Q:PROVIEN=""!(MATCH=1) D
.S PROV2=$P($G(^AUPNVPRV(PROVIEN,0)),U,1)
.I PROV=PROV2 S PROVIEN2=PROVIEN S MATCH=1
Q:MATCH=0
I MATCH=1 D
.S FILE=9000010.06
.D VDEL(FILE,PROVIEN2,VSIT)
S DCNT=$P(^AUPNVSIT(VSIT,0),U,9) ; Recheck the dependent count
Q
BADEHL4 ;IHS/MSC/MGH/VAC - Dentrix HL7 inbound interface ;01-Oct-2010 ;MGH
+1 ;;1.0;DENTAL/EDR INTERFACE;**1,4,5*;FEB 22, 2010;Build 23
+2 ;; Modified - IHS/MSC/AMF - 11/23/10 - More descriptive alert messages
+3 ;; Modified - IHS/MSC/AMF 10/2010 fix for hospital location FT1-16,2
+4 ;; Modified - IHS/OIT/GAB **4** 05/2015 for ICD10 Implementation
+5 ;; Modified - IHS/OIT/GAB **5** 03/2016 for ICD10 to accept POV from Dentrix (v 8.0.5 or later)
UPD ;EP Update a V Dental entry
+1 NEW DIEN,MATCH,DA,APCDVSIT,CODEIEN,APCDSUR,APCDTEE
+2 NEW TYPE,TCODE,SCODE,PROV,X,Y,Y2,PIEN,POVIEN2,ADACODE,VTIME
+3 NEW NOOPSITE
+4 ;patient
SET APCDALVR("APCDPAT")=DFN
+5 ;visit stored in V Dental file
+6 SET APCDVSIT=$PIECE($GET(^AUPNVDEN(EXKEY,0)),U,3)
+7 ;Added patient name, DFN, and Visit date. can't add ASUFAC or HLBIEN
+8 ;IHS/MSC/AMF 11/23/10 More descriptive alert
IF '$DATA(^AUPNVSIT(APCDVSIT))
DO ACK^BADEHL3(HLMSGIEN,DFN,"Can't update visit "_APCDVSIT_". Not in RPMS:")
QUIT
+9 SET APCDALVR("APCDVSIT")=APCDVSIT
+10 ;ADA code stored in V Dental file
+11 SET APCDTSC=$PIECE($GET(^AUPNVDEN(EXKEY,0)),U,1)
+12 SET ADACODE=$PIECE($GET(^AUTTADA(APCDTSC,0)),U,1)
+13 SET NOOPSITE=$$GET1^DIQ(9999999.31,APCDTSC,.09,"I")="n"
+14 ;See if the provider was changed
+15 SET PROV=$$GET^HLOPRS(.SEGFT1,20,1)
+16 ;IHS/MSC/AMF 11/23/10 More descriptive alert
IF PROV=""
DO ACK^BADEHL3(HLMSGIEN,DFN,"Missing provider in FT1:")
QUIT
+17 DO CHECKPRV(PROV)
+18 SET APCDALVR("APCDACS")=""
+19 SET TYPE=$$GET^HLOPRS(.SEGFT1,6)
+20 ;Check the date/time in the message
+21 SET X=$$GET^HLOPRS(.SEGFT1,4)
+22 ;IHS/MSC/AMF 11/23/10 More descriptive alert
IF X=""
DO ACK^BADEHL3(HLMSGIEN,DFN,"Missing visit date in FT1:")
QUIT
+23 IF $LENGTH(X)=8
Begin DoDot:1
+24 SET VTIME=$$GET^XPAR("ALL","BADE EDR DEFAULT TIME")
+25 ;IHS/MSC/AMF 10/2010 Change in default time
IF VTIME=""
SET VTIME=1138
+26 SET X=X_VTIME
End DoDot:1
+27 SET Y=$$FMDATE^HLFNC(X)
+28 ;/IHS/OIT/GAB CHECK FOR CODING SYSTEM TO USE **4**
SET VISDT=$PIECE(Y,".")
+29 SET Y2=$PIECE($GET(^AUPNVDEN(EXKEY,12)),U,1)
+30 ;If the date and time of the visit is different, the old procedure
+31 ;and possibly the visit must be deleted and everything restarted
+32 IF Y'=Y2
DO DEL
DO NEW^BADEHL3
QUIT
+33 ;ADA code in the message
+34 SET TCODE=$$GET^HLOPRS(.SEGFT1,7)
+35 ;IHS/MSC/AMF 11/23/10 More descriptive alert
IF TCODE=""
DO ACK^BADEHL3(HLMSGIEN,DFN,"Missing ADA code in FT1:")
QUIT
+36 IF $EXTRACT(TCODE,1,1)="D"
SET SCODE=$EXTRACT(TCODE,2,$LENGTH(TCODE))
+37 IF '$TEST
SET SCODE=TCODE
+38 SET CODEIEN=$ORDER(^AUTTADA("B",SCODE,""))
+39 SET APCDALVR("APCDTSC")="`"_CODEIEN
+40 ;Check to see if the code has changed. If the code was changed,
+41 ;the old code needs to be deleted and a new one stored
+42 IF CODEIEN'=APCDTSC
DO DELV
DO SETUP
DO ADD
+43 IF SCODE=ADACODE
DO DELV
DO SETUP
DO ADD
+44 QUIT
SETUP ;Setup the variables needed to modifiy or add
+1 NEW SURGDES
+2 SET APCDALVR("AUPNTALK")=""
+3 SET APCDALVR("APCDANE")=""
+4 ;number of units
+5 SET APCDALVR("APCDTNOU")=1
+6 ;Tooth surface
+7 SET APCDTSUR=$$GET^HLOPRS(.SEGFT1,26,4)
+8 SET APCDALVR("APCDTSUR")=APCDTSUR
+9 ;Fee for procedure
+10 SET APCDTFEE=$$GET^HLOPRS(.SEGFT1,11)
+11 SET APCDALVR("APCDTFEE")=APCDTFEE
+12 ;Date/Time
+13 SET X=$$GET^HLOPRS(.SEGFT1,4)
+14 ;IHS/MSC/AMF 11/23/10 More descriptive alert
IF X=""
DO ACK^BADEHL3(HLMSGIEN,DFN,"Missing visit date in FT1:")
QUIT
+15 IF $LENGTH(X)=8
Begin DoDot:1
+16 SET VTIME=$$GET^XPAR("ALL","BADE EDR DEFAULT TIME")
+17 IF VTIME=""
SET VTIME=1138
+18 SET X=X_VTIME
End DoDot:1
+19 SET Y=$$FMDATE^HLFNC(X)
+20 ;/IHS/OIT/GAB CHECK FOR CODING SYSTEM TO USE **4**
SET VISDT=$PIECE(Y,".")
+21 ;External format
DO DD^%DT
SET APCDTCDT=Y
+22 SET APCDALVR("APCDTCDT")=APCDTCDT
+23 SET APCDALVR("APCDTCLN")="DENTAL"
+24 SET APCDALVR("APCDTEXK")=APCDTEXK
+25 ;Provider
+26 SET PNAME=$PIECE($GET(^VA(200,PROV,0)),U,1)
+27 SET APCDALVR("APCDTEPR")=PNAME
+28 SET APCDALVR("APCDTPRV")=PNAME
+29 ; Operative Site Code (may contain text)
SET MOD=$$GET^HLOPRS(.SEGFT1,26,1)
+30 ;Operative Site Descriptive Text
SET SURGDES=$$GET^HLOPRS(.SEGFT1,26,2)
+31 SET APCDTOS=$SELECT(NOOPSITE:"",1:$$GETTOS(MOD,SURGDES))
+32 ;IHS/MSC/AMF 11/23/10 More descriptive alert
IF 'NOOPSITE
IF 'APCDTOS
DO ACK^BADEHL3(HLMSGIEN,DFN,"No valid ADA code in FT1:")
QUIT
+33 IF APCDTOS
SET APCDALVR("APCDTOS")="`"_APCDTOS
+34 ; ----- IHS/MSC/AMF 10/2010 fix for FT1-16,2
+35 ;Find the location and clinic location
+36 SET ASUFAC2=$$GET^HLOPRS(.SEGFT1,16,1)
+37 SET HOSLOC=$$GET^HLOPRS(.SEGFT1,16,2)
+38 IF $LENGTH(ASUFAC2)
IF '$LENGTH(HOSLOC)
SET ASUFAC=ASUFAC2
+39 ;
+40 SET BADEWARN=""
+41 IF $LENGTH(HOSLOC)
Begin DoDot:1
+42 SET PARLOC=+$ORDER(^SC("B",HOSLOC,""))
IF 'PARLOC
SET BADEWARN="Warning: Clinic "_HOSLOC_" is not valid "
SET HOSLOC=""
QUIT
+43 SET LOC=+$PIECE($GET(^SC(PARLOC,0)),U,4)
IF 'LOC
SET BADEWARN="Warning: Location not found for Clinic "_HOSLOC_" "
SET HOSLOC=""
End DoDot:1
+44 IF '$LENGTH(HOSLOC)
Begin DoDot:1
+45 SET LOC=$ORDER(^AUTTLOC("C",ASUFAC,""))
IF '$LENGTH(LOC)
SET BADERR="No location associated ASUFAC "_ASUFAC_":"
QUIT
+46 SET PARLOC=+$$GET^XPAR("DIV.`"_LOC_"^SYS","BADE EDR DEFAULT CLINIC")
IF 'PARLOC
SET BADERR=" There is no default clinic for this location "
QUIT
+47 SET LOCA=+$PIECE($GET(^SC(PARLOC,0)),U,4)
IF LOCA'=LOC
SET BADERR=" The LOCATION associated with this ASUFAC and BADE EDR DEFAULT CLINIC is incorrect "
QUIT
End DoDot:1
+48 ;IHS/MSC/AMF 11/23/10 More descriptive alert
IF $LENGTH(BADERR)
DO ACK^BADEHL3(HLMSGIEN,DFN,BADERR)
QUIT
+49 ;IHS/MSC/AMF 11/23/10 More descriptive alert
IF $LENGTH(BADEWARN)
DO ACK^BADEHL3(HLMSGIEN,DFN,BADEWARN)
+50 ;location
+51 ;S ASUFAC=$$GET^HLOPRS(.SEGFT1,16,1)
+52 ;S HOSLOC=$$GET^HLOPRS(.SEGFT1,16,2)
+53 ;I ASUFAC="" D ACK^BADEHL3(HLMSGIEN,DFN,"Missing location in FT1:") Q ;IHS/MSC/AMF 11/23/10 More descriptive alert
+54 ;S (LOC,PARLOC)=""
+55 ;S LOC=$O(^AUTTLOC("C",ASUFAC,LOC))
+56 ;Get the clinic location
+57 ;I HOSLOC="" D
+58 ;S PARLOC=+$$GET^XPAR("DIV.`"_LOC_"^SYS","BADE EDR DEFAULT CLINIC")
+59 ;E D
+60 ;S PARLOC=+$O(^SC("B",HOSLOC,PARLOC))
+61 ;I 'PARLOC S BADERR=" Clinic does not exist in RPMS in msg: "_$P($G(^DPT(DFN,0)),"^",1)_" "_DFN_" "_ASUFAC_" "_MIEN D ACK^BADEHL3(BADERR) Q ;IHS/MSC/VAC 10/2010
+62 ;I LOC'=$P($G(^SC(PARLOC,0)),U,4) S BADERR=" Clinic "_HOSLOC_" isn't defined for ASUFAC location "_$P($G(^DPT(DFN,0)),"^",1)_" "_DFN_" "_ASUFAC D ACK^BADEHL3(BADERR) Q ;IHS/MSC/VAC 10/2010
+63 ;
+64 ; ----- end IHS/MSC/AMF 10/2010 fix for FT1-16,2
+65 SET APCDALVR("APCDLOC")="`"_LOC
+66 ;External key
+67 SET APCDALVR("APCDTEXK")=APCDTEXK
+68 QUIT
MOD SET APCDALVR("APCDATMP")="[APCDALVR 9000010.05 (ADD)]"
+1 DO EN^APCDALVR
+2 QUIT
ADD SET APCDALVR("APCDATMP")="[APCDALVR 9000010.05 (ADD)]"
+1 DO EN^APCDALVR
+2 QUIT
DELV SET FILE=9000010.05
+1 DO VDEL(FILE,EXKEY,APCDVSIT)
+2 QUIT
DEL ;EP Delete V file entry
+1 ;Find the entry in the V DENTAL file and the visit
+2 NEW MATCH,DIEN,VSIT,DIK,DA,POV,PRV,DCNT,TEXK,DCNT2
+3 NEW APCDALVR
+4 SET DIEN=EXKEY
+5 SET TEXK=APCDTEXK
+6 ;Delete the entry
+7 ;IHS/MSC/AMF 11/23/10 More descriptive alert
IF '$DATA(^AUPNVDEN(DIEN))
DO ACK^BADEHL3(HLMSGIEN,DFN,"Can't delete visit "_DIEN_". Not in RPMS:")
QUIT
+8 SET VSIT=$PIECE($GET(^AUPNVDEN(+DIEN,0)),U,3)
+9 SET PROV=$$GET^HLOPRS(.SEGFT1,20,1)
+10 ;IHS/MSC/AMF 11/23/10 More descriptive alert
IF PROV=""
DO ACK^BADEHL3(HLMSGIEN,DFN,"Missing provider in FT1:")
QUIT
+11 ;Get the dependent count for this visit
+12 SET DCNT=$PIECE(^AUPNVSIT(VSIT,0),U,9)
+13 ;Delete this entry and quit
+14 ;I DCNT>3 D ;/IHS/OIT/GAB 3/2016 **5** commented this line
+15 SET FILE=9000010.05
+16 DO VDEL(FILE,DIEN,VSIT)
+17 SET FILE=9000010.07
+18 ;/IHS/OIT/GAB 3/2016 **5** DELETE POV AFTER PROCEDURE IS REMOVED
DO POVDEL(FILE,TEXK,VSIT)
+19 ;/IHS/OIT/GAB 3/2016 **5** REMOVE PROVIDER ENTRY IF ONE ENTRY LEFT
IF DCNT<2
DO PROVDEL(VSIT,PROV)
+20 ;If its 3, delete the VPOV and VPRV entries then delete the visit
+21 ;I DCNT<4 D ;/IHS/OIT/GAB **5** COMMENTED NEXT 4 LINES-REPLACED WITH ABOVE
+22 ;.S FILE=9000010.05
+23 ;.D VDEL(FILE,DIEN,VSIT)
+24 ;.D CHECK(VSIT,PROV)
+25 ;Delete visit if dependent count is 0
+26 IF DCNT=0
DO VSTDEL(VSIT)
+27 QUIT
VDEL(FILE,IEN,VSIT) ;Delete a V-file entry
+1 NEW X,DIK,DA
+2 SET DIK=FILE
SET DA=IEN
+3 SET X=$$DEL^APCDALVR(DIK,DA)
+4 ;IHS/MSC/AMF 11/23/10 More descriptive alert
IF X>0
DO ACK^BADEHL3(HLMSGIEN,DFN,"Can't delete V file entry:")
QUIT
+5 QUIT
VSTDEL(VSIT) ;Delete the visit with zero dependents
+1 NEW APCDVDLT,U,APCDVFLE,AUPNVSIT,APCDVNM,APCDVDG,APCDVIGR,APCDVDFN
+2 NEW APCDVI,DIK,DA
+3 SET APCDVDLT=VSIT
+4 DO EN^APCDVDLT
+5 QUIT
CHECK(VSIT,PROV) ;Remove the POV and PRV if those are the 2 remaining dependent entries
+1 NEW POVIEN,MATCH,ICD,VPRV,PROVIEN,ICDIEN,PROV2,PROVIEN2
+2 ;IHS/OIT/GAB **4** ADDED BELOW 7 LINES
+3 SET ICD=""
+4 ;/IHS/OIT/GAB **4** CK FOR WHICH CODING SYSTEM TO USE
SET I=$$IMP^BADEHL3(VISDT)
+5 ;IHS/OIT/GAB **4** IF I=30 USING ICD10, IF I=1 USING ICD9
+6 IF I=30
Begin DoDot:1
+7 SET ICD=$ORDER(^ICD9("AB","ZZZ.999",ICD))
+8 IF ICD=""
SET ICD=$ORDER(^ICD9("AB","ZZZ.999 ",ICD))
End DoDot:1
+9 IF I=1
Begin DoDot:1
+10 IF ICD=""
SET ICD=$ORDER(^ICD9("AB","V72.2",ICD))
+11 IF 'ICD
SET ICD=$ORDER(^ICD9("AB","V72.2 ",ICD))
End DoDot:1
+12 IF ICD=""
QUIT
+13 ;First the POV
+14 SET MATCH=0
+15 SET POVIEN=""
FOR
SET POVIEN=$ORDER(^AUPNVPOV("AD",VSIT,POVIEN))
IF POVIEN=""!(MATCH=1)
QUIT
Begin DoDot:1
+16 SET POVIEN2=$PIECE($GET(^AUPNVPOV(POVIEN,0)),U,1)
+17 IF ICD=POVIEN2
SET ICDIEN=POVIEN
SET MATCH=1
End DoDot:1
+18 IF MATCH=0
QUIT
+19 ;Found the POV for this visit so delete the dependent entry
+20 IF MATCH=1
Begin DoDot:1
+21 SET FILE=9000010.07
+22 DO VDEL(FILE,ICDIEN,VSIT)
End DoDot:1
+23 ;Next the provider
+24 SET (VPRV,MATCH)=0
+25 SET PROVIEN=""
FOR
SET PROVIEN=$ORDER(^AUPNVPRV("AD",VSIT,PROVIEN))
IF PROVIEN=""!(MATCH=1)
QUIT
Begin DoDot:1
+26 SET PROV2=$PIECE($GET(^AUPNVPRV(PROVIEN,0)),U,1)
+27 IF PROV=PROV2
SET PROVIEN2=PROVIEN
SET MATCH=1
End DoDot:1
+28 IF MATCH=0
QUIT
+29 IF MATCH=1
Begin DoDot:1
+30 SET FILE=9000010.06
+31 DO VDEL(FILE,PROVIEN2,VSIT)
End DoDot:1
+32 ;Recheck the dependent count
+33 SET DCNT=$PIECE(^AUPNVSIT(VSIT,0),U,9)
+34 QUIT
CHECKPRV(PROV) ;See if the provider in the message is new
+1 ;IHS/MSC/MGH 7/2010 new var PRIM for patch 1
NEW VPRV,DPRV,MATCH,PRVIEN,IEN,PPRV,PRIM
+2 ;IHS/MSC/MGH 7/2010 new var PRIM for patch 1
SET MATCH=0
SET PRIM="P"
+3 ;Find the provider in the existing V dental file
+4 SET DPRV=$PIECE($GET(^AUPNVDEN(EXKEY,12)),U,2)
+5 ;If its the same provider quit
+6 IF DPRV=PROV
QUIT
+7 ;If its not the same provider, check the visit to see if the new provider
+8 ;is already on this visit
+9 SET VPRV=""
FOR
SET VPRV=$ORDER(^AUPNVPRV("AD",APCDVSIT,VPRV))
IF VPRV=""
QUIT
Begin DoDot:1
+10 ;IHS/MSC/MGH patch 1 check for primary
+11 IF $PIECE($GET(^AUPNVPRV(VPRV,0)),U,4)="P"
SET PRIM="S"
+12 SET PRVIEN=$PIECE($GET(^AUPNVPRV(VPRV,0)),U,1)
+13 IF PROV=PRVIEN
SET MATCH=1
End DoDot:1
+14 ;If this new provider is already attached to this visit we are OK
+15 IF MATCH=1
QUIT
+16 ;If the new provider is not on this visit,add this provider
+17 ;patch 1 IHS/MSC/MGH
IF MATCH=0
DO PRV^BADEHL3(PRIM)
+18 ;Now we need to see if we need to delete the old provider.
+19 ;If this provider does not have any procedures attached we will delete
+20 SET MATCH=0
+21 SET IEN=""
FOR
SET IEN=$ORDER(^AUPNVDEN("AD",APCDVSIT,IEN))
IF IEN=""!(MATCH=1)
QUIT
Begin DoDot:1
+22 SET PPRV=$PIECE($GET(^AUPNVDEN(IEN,12)),U,2)
+23 IF PPRV=DPRV&(IEN'=EXKEY)
SET MATCH=1
End DoDot:1
+24 ;This provider is on other procedures
+25 IF MATCH=1
QUIT
+26 IF MATCH=0
Begin DoDot:1
+27 ;IHS/MSC/MGH patch 1 check for primary
NEW PP,FDA
+28 ;IHS/MSC/MGH patch 1 check for primary
SET PP=0
+29 SET PIEN=""
FOR
SET PIEN=$ORDER(^AUPNVPRV("AD",APCDVSIT,PIEN))
IF PIEN=""
QUIT
Begin DoDot:2
+30 SET PROVIEN=$PIECE($GET(^AUPNVPRV(PIEN,0)),U,1)
+31 ;IHS/MSC/MGH patch 1 check for primary
+32 ; IHS/MSC/MGH patch 1 We are deleting the primary provider
IF $PIECE($GET(^AUPNVPRV(PIEN,0)),U,4)="P"
SET PP=1
+33 IF PROVIEN=DPRV
Begin DoDot:3
+34 SET FILE=9000010.06
+35 DO VDEL(FILE,PIEN,APCDVSIT)
+36 ;ISH/MSC/MGH PATCH 1 If primary provider was deleted, make the new provider primary
+37 IF PP=1
Begin DoDot:4
+38 SET PIEN=""
FOR
SET IEN=$ORDER(^AUPNVPRV("AD",APCDVSIT,PIEN))
IF PIEN=""
QUIT
Begin DoDot:5
+39 SET PROVIEN=$PIECE($GET(^AUPNVPRV(PIEN,0)),U,1)
+40 IF PROVIEN=PROV
Begin DoDot:6
+41 SET FDA=9000010.06
+42 SET FDA=$NAME(FDA(FNUM,PIEN_","))
+43 SET @FDA@(.04)="P"
+44 KILL FDA
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+45 ; ----- end ISH/MSC/MGH PATCH 1 If primary provider was deleted
+46 QUIT
+47 ; Returns Dental Operative Code IEN
GETTOS(CODE,DESC) ;EP
+1 IF '$LENGTH(DESC)
QUIT 0
+2 NEW RET,LP
+3 SET RET=0
+4 ;"B" only contains first 30 characters
IF $LENGTH(DESC)>30
Begin DoDot:1
+5 SET LP=0
FOR
SET LP=$ORDER(^ADEOPS(LP))
IF 'LP
QUIT
Begin DoDot:2
+6 IF $PIECE(^ADEOPS(LP,0),U)=DESC
SET RET=LP
End DoDot:2
IF RET
QUIT
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 SET RET=+$ORDER(^ADEOPS("B",DESC,0))
End DoDot:1
+9 QUIT RET
POVDEL(FILE,IEN,VSIT) ;/IHS/OIT/GAB **5** ADDED THIS SEGMENT TO CHECK THE POV ENTRIES & DELETE
+1 NEW EKEY,MATCH,VPRV,PROVIEN,PROV2,PROVIEN2
+2 SET ICDIEN=""
SET POVIEN=""
SET POVIEN2=""
SET KEY=""
SET ICD=""
+3 ;SET THE EXTERNAL KEY
SET EKEY=IEN
+4 ;WHICH CODING SYSTEM TO USE ICD9=1 OR ICD10=30
SET I=$$IMP^BADEHL3(VISDT)
+5 IF I=30
Begin DoDot:1
+6 SET POVIEN=$ORDER(^AUPNVPOV("AD",VSIT,POVIEN))
+7 IF POVIEN=""
QUIT
+8 ; set the external key
SET KEY=$PIECE($GET(^AUPNVPOV(POVIEN,12)),U,9)
+9 IF KEY
Begin DoDot:2
+10 SET POVIEN=""
FOR
SET POVIEN=$ORDER(^AUPNVPOV("AD",VSIT,POVIEN))
IF POVIEN=""
QUIT
Begin DoDot:3
+11 SET KEY=$PIECE($GET(^AUPNVPOV(POVIEN,12)),U,9)
+12 IF KEY=EKEY
Begin DoDot:4
+13 SET ICDIEN=$PIECE($GET(^AUPNVPOV(POVIEN,0)),U,1)
+14 IF ICDIEN
Begin DoDot:5
+15 SET FILE=9000010.07
+16 SET ICDIEN=POVIEN
+17 DO VDEL(FILE,ICDIEN,VSIT)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+18 ;/IHS/OIT/GAB **5** NO EXTERNAL KEY SO SET TO ZZZ.999
IF '$TEST
Begin DoDot:2
+19 SET ICD=$ORDER(^ICD9("AB","ZZZ.999",ICD))
+20 IF ICD=""
SET ICD=$ORDER(^ICD9("AB","ZZZ.999 ",ICD))
+21 IF ICD=""
QUIT
+22 SET MATCH=0
+23 SET POVIEN=""
FOR
SET POVIEN=$ORDER(^AUPNVPOV("AD",VSIT,POVIEN))
IF POVIEN=""!(MATCH=1)
QUIT
Begin DoDot:3
+24 SET POVIEN2=$PIECE($GET(^AUPNVPOV(POVIEN,0)),U,1)
+25 IF ICD=POVIEN2
SET ICDIEN=POVIEN
SET MATCH=1
End DoDot:3
+26 IF MATCH=0
QUIT
+27 ;Found the POV for this visit so delete the dependent entry
IF MATCH=1
Begin DoDot:3
+28 SET FILE=9000010.07
+29 DO VDEL(FILE,ICDIEN,VSIT)
End DoDot:3
End DoDot:2
End DoDot:1
+30 ;/IHS/OIT/GAB **5** IF NOT ICD10 REMOVE V72.2
IF I=1
Begin DoDot:1
+31 SET ICD=$ORDER(^ICD9("AB","V72.2",ICD))
+32 IF 'ICD
SET ICD=$ORDER(^ICD9("AB","V72.2 ",ICD))
+33 IF ICD=""
QUIT
+34 ;find the POV
SET MATCH=0
+35 SET POVIEN=""
FOR
SET POVIEN=$ORDER(^AUPNVPOV("AD",VSIT,POVIEN))
IF POVIEN=""!(MATCH=1)
QUIT
Begin DoDot:2
+36 SET POVIEN2=$PIECE($GET(^AUPNVPOV(POVIEN,0)),U,1)
+37 IF ICD=POVIEN2
SET ICDIEN=POVIEN
SET MATCH=1
End DoDot:2
+38 IF MATCH=0
QUIT
+39 ;found the match so remove the POV
IF MATCH=1
Begin DoDot:2
+40 SET FILE=9000010.07
+41 DO VDEL(FILE,ICDIEN,VSIT)
End DoDot:2
End DoDot:1
+42 SET DCNT=$PIECE(^AUPNVSIT(VSIT,0),U,9)
+43 QUIT
PROVDEL(VSIT,PROV) ;/IHS/OIT/GAB ADDED TO REMOVE PROVIDER ENTRY
+1 NEW MATCH,VPRV,PROVIEN,PROV2,PROVIEN2
+2 SET (VPRV,MATCH)=0
+3 SET PROVIEN=""
FOR
SET PROVIEN=$ORDER(^AUPNVPRV("AD",VSIT,PROVIEN))
IF PROVIEN=""!(MATCH=1)
QUIT
Begin DoDot:1
+4 SET PROV2=$PIECE($GET(^AUPNVPRV(PROVIEN,0)),U,1)
+5 IF PROV=PROV2
SET PROVIEN2=PROVIEN
SET MATCH=1
End DoDot:1
+6 IF MATCH=0
QUIT
+7 IF MATCH=1
Begin DoDot:1
+8 SET FILE=9000010.06
+9 DO VDEL(FILE,PROVIEN2,VSIT)
End DoDot:1
+10 ; Recheck the dependent count
SET DCNT=$PIECE(^AUPNVSIT(VSIT,0),U,9)
+11 QUIT
