AICDUNK ;IHS/SD/RNB - ACPT unknown bad entries ;
;;3.51;IHS ICD/CPT lookup & grouper;**10**;Nov 08, 1991
;
Q
ENT ;
; Main entry point
N ACPTIEN,ACPTCNT,INACT
S ACPTIEN=0,ACPTCNT=0,ACPTYR=DT
W !,"INACTIVATING CPT CODES WITH 'unknown' RECORD ENTRIES: "
W !,?7,"CODE",?14,"DESCRIPTION",?29,"EIN #"
F S ACPTIEN=$O(^ICPT(ACPTIEN)) Q:(ACPTIEN'?1N.N) D DELETE
Q
DELETE ;
S ACPTCNT=ACPTCNT+1
;I '(ACPTCNT#100) W "."
I $$VERSION^XPDUTL("BCSV")<1 D DELETE1 ;(non-CSV) Inactivate all codes
I $$VERSION^XPDUTL("BCSV")>0 D DELETE2 ;(CSV) Inactivate all codes
Q
DELETE1 ;
;
S ACPTDESC="Couldn't find code to inactivate",ACPTCODE="",INACT="",ACPTDESC=""
S:$P($G(^ICPT(ACPTIEN,0)),U,2)'="" ACPTDESC=$P(^ICPT(ACPTIEN,0),U,2),INACT=$P(^ICPT(ACPTIEN,0),U,4),ACPTCODE=$P(^ICPT(ACPTIEN,0),U,1)
I ACPTCODE="" Q
I $E(ACPTCODE)?1U Q
I $E(ACPTCODE,1,3)="000" Q
I INACT=1 Q
I ACPTDESC'="unknown" Q
W !,?7,ACPTCODE,?14,ACPTDESC,?29,ACPTIEN
S $P(^ICPT(ACPTIEN,0),U,4)=1,$P(^ICPT(ACPTIEN,0),U,7)=ACPTYR ; Date Deleted (8)
;
K DIC,DIE,DIR,X,Y,DA,DR
S DA(1)=ACPTIEN ; parent record, i.e., the CPT code
S DIC="^ICPT("_DA(1)_",60," ; Effective Date subfile (60/81.02)
S DIC(0)="L" ; allow LAYGO (Learn As You Go, i.e., add if not found)
S DIC("P")=$P(^DD(81,60,0),"^",2) ; subfile # & specifier codes
S X="01/01/2011" ; value to lookup in the subfile
D ^DIC ; Fileman Lookup call
S DA=+Y ; save IEN of found/added record for next call below
;
K DIR,DIE,DIC,X,Y,DR
S DA(1)=ACPTIEN
S DIE="^ICPT("_DA(1)_",60," ; Effective Date subfile (60/81.02)
S DR=".02////0" ; set Status field to INACTIVE
D ^DIE ; Fileman Data Edit call
Q
DELETE2 ;
;
S ACPTSHRT="Couldn't find code to inactivate",ACPTCODE="",INACT="",ACPTDESC=""
S:$P($G(^ICPT(ACPTIEN,0)),U,2)'="" ACPTSHRT=$P(^ICPT(ACPTIEN,0),U,2),INACT=$P(^ICPT(ACPTIEN,0),U,4),ACPTCODE=$P(^ICPT(ACPTIEN,0),U,1)
I ACPTCODE="" Q
I $E(ACPTCODE)?1U Q
I $E(ACPTCODE,1,3)="000" Q
I INACT=1 Q
I ACPTSHRT'="unknown" Q
W !,?7,ACPTCODE,?14,ACPTSHRT,?29,ACPTIEN
;
K DIC,DIE,DIR,X,Y,DA,DR
S DA(1)=ACPTIEN ; parent record, i.e., the CPT code
S DIC="^ICPT("_DA(1)_",60," ; Effective Date subfile (60/81.02)
S DIC(0)="L" ; allow LAYGO (Learn As You Go, i.e., add if not found)
S DIC("P")=$P(^DD(81,60,0),"^",2) ; subfile # & specifier codes
S X="01/01/2011" ; value to lookup in the subfile
N DLAYGO,Y,DTOUT,DUOUT ; other parameters for DIC
D ^DIC ; Fileman Lookup call
S DA=+Y ; save IEN of found/added record for next call below
;
K DIR,DIE,DIC,X,Y,DR
S DA(1)=ACPTIEN
S DIE="^ICPT("_DA(1)_",60," ; Effective Date subfile (60/81.02)
S DR=".02////0" ; set Status field to INACTIVE
N DIDEL,DTOUT ; other parameters for DIE
D ^DIE ; Fileman Data Edit call
;
K DIC,DIE,DIR,X,Y,DA,DR
S DIE="^ICPT("
S DA=ACPTIEN
S DR="5////1;7////3101231;9999999.07////3101231"
D ^DIE
Q
AICDUNK ;IHS/SD/RNB - ACPT unknown bad entries ;
+1 ;;3.51;IHS ICD/CPT lookup & grouper;**10**;Nov 08, 1991
+2 ;
+3 QUIT
ENT ;
+1 ; Main entry point
+2 NEW ACPTIEN,ACPTCNT,INACT
+3 SET ACPTIEN=0
SET ACPTCNT=0
SET ACPTYR=DT
+4 WRITE !,"INACTIVATING CPT CODES WITH 'unknown' RECORD ENTRIES: "
+5 WRITE !,?7,"CODE",?14,"DESCRIPTION",?29,"EIN #"
+6 FOR
SET ACPTIEN=$ORDER(^ICPT(ACPTIEN))
IF (ACPTIEN'?1N.N)
QUIT
DO DELETE
+7 QUIT
DELETE ;
+1 SET ACPTCNT=ACPTCNT+1
+2 ;I '(ACPTCNT#100) W "."
+3 ;(non-CSV) Inactivate all codes
IF $$VERSION^XPDUTL("BCSV")<1
DO DELETE1
+4 ;(CSV) Inactivate all codes
IF $$VERSION^XPDUTL("BCSV")>0
DO DELETE2
+5 QUIT
DELETE1 ;
+1 ;
+2 SET ACPTDESC="Couldn't find code to inactivate"
SET ACPTCODE=""
SET INACT=""
SET ACPTDESC=""
+3 IF $PIECE($GET(^ICPT(ACPTIEN,0)),U,2)'=""
SET ACPTDESC=$PIECE(^ICPT(ACPTIEN,0),U,2)
SET INACT=$PIECE(^ICPT(ACPTIEN,0),U,4)
SET ACPTCODE=$PIECE(^ICPT(ACPTIEN,0),U,1)
+4 IF ACPTCODE=""
QUIT
+5 IF $EXTRACT(ACPTCODE)?1U
QUIT
+6 IF $EXTRACT(ACPTCODE,1,3)="000"
QUIT
+7 IF INACT=1
QUIT
+8 IF ACPTDESC'="unknown"
QUIT
+9 WRITE !,?7,ACPTCODE,?14,ACPTDESC,?29,ACPTIEN
+10 ; Date Deleted (8)
SET $PIECE(^ICPT(ACPTIEN,0),U,4)=1
SET $PIECE(^ICPT(ACPTIEN,0),U,7)=ACPTYR
+11 ;
+12 KILL DIC,DIE,DIR,X,Y,DA,DR
+13 ; parent record, i.e., the CPT code
SET DA(1)=ACPTIEN
+14 ; Effective Date subfile (60/81.02)
SET DIC="^ICPT("_DA(1)_",60,"
+15 ; allow LAYGO (Learn As You Go, i.e., add if not found)
SET DIC(0)="L"
+16 ; subfile # & specifier codes
SET DIC("P")=$PIECE(^DD(81,60,0),"^",2)
+17 ; value to lookup in the subfile
SET X="01/01/2011"
+18 ; Fileman Lookup call
DO ^DIC
+19 ; save IEN of found/added record for next call below
SET DA=+Y
+20 ;
+21 KILL DIR,DIE,DIC,X,Y,DR
+22 SET DA(1)=ACPTIEN
+23 ; Effective Date subfile (60/81.02)
SET DIE="^ICPT("_DA(1)_",60,"
+24 ; set Status field to INACTIVE
SET DR=".02////0"
+25 ; Fileman Data Edit call
DO ^DIE
+26 QUIT
DELETE2 ;
+1 ;
+2 SET ACPTSHRT="Couldn't find code to inactivate"
SET ACPTCODE=""
SET INACT=""
SET ACPTDESC=""
+3 IF $PIECE($GET(^ICPT(ACPTIEN,0)),U,2)'=""
SET ACPTSHRT=$PIECE(^ICPT(ACPTIEN,0),U,2)
SET INACT=$PIECE(^ICPT(ACPTIEN,0),U,4)
SET ACPTCODE=$PIECE(^ICPT(ACPTIEN,0),U,1)
+4 IF ACPTCODE=""
QUIT
+5 IF $EXTRACT(ACPTCODE)?1U
QUIT
+6 IF $EXTRACT(ACPTCODE,1,3)="000"
QUIT
+7 IF INACT=1
QUIT
+8 IF ACPTSHRT'="unknown"
QUIT
+9 WRITE !,?7,ACPTCODE,?14,ACPTSHRT,?29,ACPTIEN
+10 ;
+11 KILL DIC,DIE,DIR,X,Y,DA,DR
+12 ; parent record, i.e., the CPT code
SET DA(1)=ACPTIEN
+13 ; Effective Date subfile (60/81.02)
SET DIC="^ICPT("_DA(1)_",60,"
+14 ; allow LAYGO (Learn As You Go, i.e., add if not found)
SET DIC(0)="L"
+15 ; subfile # & specifier codes
SET DIC("P")=$PIECE(^DD(81,60,0),"^",2)
+16 ; value to lookup in the subfile
SET X="01/01/2011"
+17 ; other parameters for DIC
NEW DLAYGO,Y,DTOUT,DUOUT
+18 ; Fileman Lookup call
DO ^DIC
+19 ; save IEN of found/added record for next call below
SET DA=+Y
+20 ;
+21 KILL DIR,DIE,DIC,X,Y,DR
+22 SET DA(1)=ACPTIEN
+23 ; Effective Date subfile (60/81.02)
SET DIE="^ICPT("_DA(1)_",60,"
+24 ; set Status field to INACTIVE
SET DR=".02////0"
+25 ; other parameters for DIE
NEW DIDEL,DTOUT
+26 ; Fileman Data Edit call
DO ^DIE
+27 ;
+28 KILL DIC,DIE,DIR,X,Y,DA,DR
+29 SET DIE="^ICPT("
+30 SET DA=ACPTIEN
+31 SET DR="5////1;7////3101231;9999999.07////3101231"
+32 DO ^DIE
+33 QUIT
