ACDPCCL7 ;IHS/ADC/EDE/KML - PCC LINK - EDIT ENTRY;
;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
;
START ;
D MAIN
Q
;
MAIN ;
S X=$O(ACDPCCL(ACDDFNP,ACDVIEN,""))
I X="CS" D CS Q
D IIFTDC
Q
;
IIFTDC ;
D VFILES
D VISIT
S DIK="^ACDVIS("_ACDVIEN_",21,",DA=1,DA(1)=ACDVIEN D DIK^ACDFMC
Q
;
VFILES ; DELETE V FILE ENTRIES
S ACDY=0
F S ACDY=$O(^ACDVIS(ACDVIEN,21,1,11,ACDY)) Q:'ACDY I $D(^(ACDY,0)) S X=^(0) D
. S ACDVF=$P(X,U)
. S ACDVFE=$P(X,U,2)
. ;S X=$$DEL^APCDALVR(ACDVF,ACDVFE)
. S X=$$DEL(ACDVF,ACDVFE)
. I X D ERROR^ACDPCCL("Error code="_X_" encountered while deleting V File entry",3) Q
. Q
Q
;
VISIT ; DELETE VISIT IF DEPENDENT ENTRY COUNT = 0
Q:'$D(^ACDVIS(ACDVIEN,21,1,0)) ; corrupt cdmis visit
S X=^ACDVIS(ACDVIEN,21,1,0)
NEW AUPNVSIT
S AUPNVSIT=$P(X,U,2)
Q:$P(^AUPNVSIT(AUPNVSIT,0),U,9)
D DEL^AUPNVSIT
Q
;
CS ;
S ACDCSIEN=0
F S ACDCSIEN=$O(ACDPCCL(ACDDFNP,ACDVIEN,"CS",ACDCSIEN)) Q:'ACDCSIEN D CS2 K ACDPCCL(ACDDFNP,ACDVIEN,"CS",ACDCSIEN)
I '$O(ACDPCCL(ACDDFNP,ACDVIEN,"")) K ACDPCCL(ACDDFNP,ACDVIEN)
; *** The kills above will preclude any CS entry ever being added
; *** back by the add logic in ^ACDPCCL5. Might rethink this.
Q
;
CS2 ;
I $D(^ACDVIS(ACDVIEN,21,"AC",ACDCSIEN)) S ACDDMIEN=$O(^(ACDCSIEN,0)),ACDVMIEN=$O(^(ACDDMIEN,0)) D
. S ACDPCCV=$P($G(^ACDVIS(ACDVIEN,21,ACDDMIEN,0)),U,2)
. Q:'ACDPCCV ; quit if no PCC visit ien
. S X=$G(^ACDVIS(ACDVIEN,21,ACDDMIEN,11,ACDVMIEN,0))
. S ACDVCPT=$P(X,U,2) ; get ^AUPNVCPT ien
. Q:'ACDVCPT
. I ACDPCCL(ACDDFNP,ACDVIEN,"CS",ACDCSIEN)="D" D CSDEL Q
. ;if CS entry deleted delete AUPNVCPT entry and ACDVIS mult entry
. S ACDCSIEN=$P(X,U,3) ; get ^ACDCS ien
. Q:'ACDCSIEN
. S X=+$G(^AUPNVCPT(ACDVCPT,0)) ; get CPT code from PCC
. Q:'X
. S Y=$P($G(^ACDCS(ACDCSIEN,0)),U,2) ; get ^ACDSERV ien
. Q:'Y
. S Y=$P($G(^ACDSERV(Y,0)),U,5) ; get CPT code from CDMIS
. Q:'Y
. Q:X=Y ; quit if CPT codes same
. S APCDALVR("APCDLOOK")=ACDVCPT
. S APCDALVR("APCDTCPT")=Y
. S APCDALVR("APCDVSIT")=ACDPCCV
. S APCDALVR("APCDATMP")="[APCDALVR 9000010.18 (MOD)]"
. D ^APCDALVR
. I $D(APCDALVR("APCDAFLG")) D ERROR^ACDPCCL("Error flag="_APCDALVR("APCDAFLG")_" returned by APCDALVR while modifying the V CPT file.",3)
. K APCDALVR
. Q
Q
;
CSDEL ; DELETED CS ENTRY
S X=$$DEL(9000010.18,ACDVCPT)
I X D ERROR^ACDPCCL("Error code="_X_" encountered while deleting V File entry",3)
I $D(^ACDVIS(ACDVIEN,21,"AC",ACDCSIEN)) S ACDDMIEN=$O(^(ACDCSIEN,0)),ACDVMIEN=$O(^(ACDDMIEN,0)) D
S DIK="^ACDVIS("_ACDVIEN_",21,"_ACDDMIEN_",11,",DA=ACDVMIEN,DA(1)=ACDDMIEN,DA(2)=ACDVIEN
D DIK^ACDFMC
Q
;
; ***** CHG CALL TO $$DEL^APCDALVR WHEN RELEASED *****
DEL(DIK,DA) ; DELETE ONE V FILE ENTRY
;
; Meaning of returned values are:
; 0 = v file entry deleted
; 1 = data global invalid
; 2 = no 0th node for data global
; 3 = specified file is not a v file
; 4 = specified entry is not in specified v file
;
S:DIK DIK=$G(^DIC(DIK,0,"GL")) ; get data gbl if file #
I DIK'?1"^".E1"(".E Q 1 ; data gbl invalid
S X=$E(DIK,$L(DIK)) ; get last chr of gbl
I X'="(",X'="," Q 1 ; data gbl invalid
I '$D(@(DIK_"0)")) Q 2 ; no 0th node for data gbl
S X=+$P(@(DIK_"0)"),U,2) ; get file #
I $P(X,".")'=9000010 Q 3 ; not a v file
I X=9000010 Q 3 ; not a v file
I '$D(@(DIK_DA_",0)")) Q 4 ; entry not in v file
D DIK^ACDFMC ; delete v file entry
Q 0
ACDPCCL7 ;IHS/ADC/EDE/KML - PCC LINK - EDIT ENTRY;
+1 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
+2 ;
START ;
+1 DO MAIN
+2 QUIT
+3 ;
MAIN ;
+1 SET X=$ORDER(ACDPCCL(ACDDFNP,ACDVIEN,""))
+2 IF X="CS"
DO CS
QUIT
+3 DO IIFTDC
+4 QUIT
+5 ;
IIFTDC ;
+1 DO VFILES
+2 DO VISIT
+3 SET DIK="^ACDVIS("_ACDVIEN_",21,"
SET DA=1
SET DA(1)=ACDVIEN
DO DIK^ACDFMC
+4 QUIT
+5 ;
VFILES ; DELETE V FILE ENTRIES
+1 SET ACDY=0
+2 FOR
SET ACDY=$ORDER(^ACDVIS(ACDVIEN,21,1,11,ACDY))
IF 'ACDY
QUIT
IF $DATA(^(ACDY,0))
SET X=^(0)
Begin DoDot:1
+3 SET ACDVF=$PIECE(X,U)
+4 SET ACDVFE=$PIECE(X,U,2)
+5 ;S X=$$DEL^APCDALVR(ACDVF,ACDVFE)
+6 SET X=$$DEL(ACDVF,ACDVFE)
+7 IF X
DO ERROR^ACDPCCL("Error code="_X_" encountered while deleting V File entry",3)
QUIT
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
VISIT ; DELETE VISIT IF DEPENDENT ENTRY COUNT = 0
+1 ; corrupt cdmis visit
IF '$DATA(^ACDVIS(ACDVIEN,21,1,0))
QUIT
+2 SET X=^ACDVIS(ACDVIEN,21,1,0)
+3 NEW AUPNVSIT
+4 SET AUPNVSIT=$PIECE(X,U,2)
+5 IF $PIECE(^AUPNVSIT(AUPNVSIT,0),U,9)
QUIT
+6 DO DEL^AUPNVSIT
+7 QUIT
+8 ;
CS ;
+1 SET ACDCSIEN=0
+2 FOR
SET ACDCSIEN=$ORDER(ACDPCCL(ACDDFNP,ACDVIEN,"CS",ACDCSIEN))
IF 'ACDCSIEN
QUIT
DO CS2
KILL ACDPCCL(ACDDFNP,ACDVIEN,"CS",ACDCSIEN)
+3 IF '$ORDER(ACDPCCL(ACDDFNP,ACDVIEN,""))
KILL ACDPCCL(ACDDFNP,ACDVIEN)
+4 ; *** The kills above will preclude any CS entry ever being added
+5 ; *** back by the add logic in ^ACDPCCL5. Might rethink this.
+6 QUIT
+7 ;
CS2 ;
+1 IF $DATA(^ACDVIS(ACDVIEN,21,"AC",ACDCSIEN))
SET ACDDMIEN=$ORDER(^(ACDCSIEN,0))
SET ACDVMIEN=$ORDER(^(ACDDMIEN,0))
Begin DoDot:1
+2 SET ACDPCCV=$PIECE($GET(^ACDVIS(ACDVIEN,21,ACDDMIEN,0)),U,2)
+3 ; quit if no PCC visit ien
IF 'ACDPCCV
QUIT
+4 SET X=$GET(^ACDVIS(ACDVIEN,21,ACDDMIEN,11,ACDVMIEN,0))
+5 ; get ^AUPNVCPT ien
SET ACDVCPT=$PIECE(X,U,2)
+6 IF 'ACDVCPT
QUIT
+7 IF ACDPCCL(ACDDFNP,ACDVIEN,"CS",ACDCSIEN)="D"
DO CSDEL
QUIT
+8 ;if CS entry deleted delete AUPNVCPT entry and ACDVIS mult entry
+9 ; get ^ACDCS ien
SET ACDCSIEN=$PIECE(X,U,3)
+10 IF 'ACDCSIEN
QUIT
+11 ; get CPT code from PCC
SET X=+$GET(^AUPNVCPT(ACDVCPT,0))
+12 IF 'X
QUIT
+13 ; get ^ACDSERV ien
SET Y=$PIECE($GET(^ACDCS(ACDCSIEN,0)),U,2)
+14 IF 'Y
QUIT
+15 ; get CPT code from CDMIS
SET Y=$PIECE($GET(^ACDSERV(Y,0)),U,5)
+16 IF 'Y
QUIT
+17 ; quit if CPT codes same
IF X=Y
QUIT
+18 SET APCDALVR("APCDLOOK")=ACDVCPT
+19 SET APCDALVR("APCDTCPT")=Y
+20 SET APCDALVR("APCDVSIT")=ACDPCCV
+21 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.18 (MOD)]"
+22 DO ^APCDALVR
+23 IF $DATA(APCDALVR("APCDAFLG"))
DO ERROR^ACDPCCL("Error flag="_APCDALVR("APCDAFLG")_" returned by APCDALVR while modifying the V CPT file.",3)
+24 KILL APCDALVR
+25 QUIT
End DoDot:1
+26 QUIT
+27 ;
CSDEL ; DELETED CS ENTRY
+1 SET X=$$DEL(9000010.18,ACDVCPT)
+2 IF X
DO ERROR^ACDPCCL("Error code="_X_" encountered while deleting V File entry",3)
+3 IF $DATA(^ACDVIS(ACDVIEN,21,"AC",ACDCSIEN))
SET ACDDMIEN=$ORDER(^(ACDCSIEN,0))
SET ACDVMIEN=$ORDER(^(ACDDMIEN,0))
Begin DoDot:1
End DoDot:1
+4 SET DIK="^ACDVIS("_ACDVIEN_",21,"_ACDDMIEN_",11,"
SET DA=ACDVMIEN
SET DA(1)=ACDDMIEN
SET DA(2)=ACDVIEN
+5 DO DIK^ACDFMC
+6 QUIT
+7 ;
+8 ; ***** CHG CALL TO $$DEL^APCDALVR WHEN RELEASED *****
DEL(DIK,DA) ; DELETE ONE V FILE ENTRY
+1 ;
+2 ; Meaning of returned values are:
+3 ; 0 = v file entry deleted
+4 ; 1 = data global invalid
+5 ; 2 = no 0th node for data global
+6 ; 3 = specified file is not a v file
+7 ; 4 = specified entry is not in specified v file
+8 ;
+9 ; get data gbl if file #
IF DIK
SET DIK=$GET(^DIC(DIK,0,"GL"))
+10 ; data gbl invalid
IF DIK'?1"^".E1"(".E
QUIT 1
+11 ; get last chr of gbl
SET X=$EXTRACT(DIK,$LENGTH(DIK))
+12 ; data gbl invalid
IF X'="("
IF X'=","
QUIT 1
+13 ; no 0th node for data gbl
IF '$DATA(@(DIK_"0)"))
QUIT 2
+14 ; get file #
SET X=+$PIECE(@(DIK_"0)"),U,2)
+15 ; not a v file
IF $PIECE(X,".")'=9000010
QUIT 3
+16 ; not a v file
IF X=9000010
QUIT 3
+17 ; entry not in v file
IF '$DATA(@(DIK_DA_",0)"))
QUIT 4
+18 ; delete v file entry
DO DIK^ACDFMC
+19 QUIT 0
