ACPTLEX ; IHS/ITSC/LJF,SDR - Move ICPT multiple to other systems [ 07/22/2003 2:04 PM ]
;;2.03;CPT FILES;**2**;DEC 04, 2002
; New routine - 05/2003
; Routine supplied by Linda Fels. Minor mods have been made to
; account for CPT files that may not be correct to get the most
; hits and to account for a temp file specifically for errors.
;
Q
;
BUILD ;EP; build temp global for transport
K ^ACPTMP("ICPT")
NEW X
S X=0 F S X=$O(^ICPT(X)) Q:'X M ^ACPTMP("ICPT",X,0)=^ICPT(X,0) M ^ACPTMP("ICPT",X,60)=^ICPT(X,60)
Q
;
PRE ;EP; remove old field 405.3 which uses 81.02 subfile number
NEW DIU,DIK
S DIU=81.02,DIU(0)="S" D EN^DIU2
S DIK="^DD(81,",DA=409.3,DA(1)=81 D ^DIK
Q
;
POST ;EP; build effective date multiple for ^ICPT global
;I '$D(^ACPTMP("ICPT")) W !!,"NO DATA GLOBAL FOUND!" Q
;K ^ACPTMP("ICPTE") ;error global
K ^ACPTEMP("ICPTE") ;error global
NEW IEN,XCOD,INACTIVE,DELDT,ADDDT
S IEN=0
F S IEN=$O(^ICPT(IEN)) Q:IEN'=+IEN D
. S ACPTCD=$P($G(^ICPT(IEN,0)),"^") ;actual CPT code
. I ACPTCD="" S ^ACPTEMP("ICPTE",IEN,0)="NO CPT CODE" Q
. S ACPTIEN=$O(^ACPTMP("B",ACPTCD,0)) ;what IEN into tmp file is
. I ACPTIEN="" S ^ACPTEMP("ICPTE",IEN,0)="NO CODE IN OUR FILE" Q
. ;
. ; check if already has effective date multiple
. Q:$O(^ICPT(IEN,60,0))
. ;
. ; do data checks
. S XCOD=$P($G(^ACPTMP(ACPTIEN,0)),U)
. I XCOD'=$P(^ICPT(IEN,0),U) S ^ACPTEMP("ICPTE",IEN,0)=XCOD Q ;codes are different
. ;
. S INACTIVE=$$GET1^DIQ(81,IEN,5,"I")
. I INACTIVE,$$GET1^DIQ(81,IEN,8)="" S ^ACPTEMP("ICPTE",IEN,0)="NO DATE DELETED" Q
. I 'INACTIVE I $$GET1^DIQ(81,IEN,7,"I")<$$GET1^DIQ(81,IEN,8,"I") S ^ACPTEMP("ICPTE",IEN,0)="EARLIER ADD DATE" Q
. ;
. ; add effective date data
. ;M ^ICPT(IEN,60)=^ACPTMP(ACPTIEN,60) ;IHS/SD/SDR 8/21/03
. ;IHS/SD/SDR 8/21/03
. S ACPTCNT=0
. F S ACPTCNT=$O(^ACPTMP(ACPTIEN,60,ACPTCNT)) Q:ACPTCNT="" D
.. S ACPTEDT=$P($G(^ACPTMP(ACPTIEN,60,ACPTCNT,0)),"^")
.. S ACPTSTA=$P($G(^ACPTMP(ACPTIEN,60,ACPTCNT,0)),"^",2)
.. S X=ACPTEDT
.. S DA(1)=ACPTIEN
.. S DIC="^ICPT("_ACPTIEN_",60,"
.. S DIC(0)="LMX"
.. S DIC("P")=$P(^DD(81,60,0),"^",2)
.. S DIC("DR")=".02///"_ACPTSTA
.. D ^DIC
. ;IHS/SD/SDR 8/21/03
. ;
. ; now fill in if no effective date added
. Q:$O(^ICPT(IEN,60,0))
. I INACTIVE S DELDT=$$GET1^DIQ(81,IEN,8,"I") Q:'DELDT D ADD(IEN,DELDT,0) Q
. I 'INACTIVE S ADDDT=$$GET1^DIQ(81,IEN,7,"I") Q:'ADDDT D ADD(IEN,ADDDT,1)
;
; now remove temp file and data
NEW DIU,DIK
S DIU=90335,DIU(0)="DT"
D EN^DIU2
;
; add/edit/delete codes effective 7/1/2003
D START^ACPT23P2
Q
;
ADD(IEN,DATE,STATUS) ; stuff effective date multiple
; IEN=CPT internal entry number
; DATE=effective date
; STATUS=1 for active, 0 for inactive
NEW DD,DO,DIC,X,DA,DLAYGO
S DIC(0)="L",DLAYGO=81.02,DIC("P")=$P(^DD(81,60,0),U,2)
S DIC="^ICPT("_IEN_",60,"
S DA(1)=IEN
S X=DATE
S DIC("DR")=".02///"_STATUS
D FILE^DICN
Q
;
RESET ;EP; delete 60 multiple to start over
NEW IEN
S IEN=0 F S IEN=$O(^ICPT(IEN)) Q:'IEN K ^ICPT(IEN,60)
Q
ACPTLEX ; IHS/ITSC/LJF,SDR - Move ICPT multiple to other systems [ 07/22/2003 2:04 PM ]
+1 ;;2.03;CPT FILES;**2**;DEC 04, 2002
+2 ; New routine - 05/2003
+3 ; Routine supplied by Linda Fels. Minor mods have been made to
+4 ; account for CPT files that may not be correct to get the most
+5 ; hits and to account for a temp file specifically for errors.
+6 ;
+7 QUIT
+8 ;
BUILD ;EP; build temp global for transport
+1 KILL ^ACPTMP("ICPT")
+2 NEW X
+3 SET X=0
FOR
SET X=$ORDER(^ICPT(X))
IF 'X
QUIT
MERGE ^ACPTMP("ICPT",X,0)=^ICPT(X,0)
MERGE ^ACPTMP("ICPT",X,60)=^ICPT(X,60)
+4 QUIT
+5 ;
PRE ;EP; remove old field 405.3 which uses 81.02 subfile number
+1 NEW DIU,DIK
+2 SET DIU=81.02
SET DIU(0)="S"
DO EN^DIU2
+3 SET DIK="^DD(81,"
SET DA=409.3
SET DA(1)=81
DO ^DIK
+4 QUIT
+5 ;
POST ;EP; build effective date multiple for ^ICPT global
+1 ;I '$D(^ACPTMP("ICPT")) W !!,"NO DATA GLOBAL FOUND!" Q
+2 ;K ^ACPTMP("ICPTE") ;error global
+3 ;error global
KILL ^ACPTEMP("ICPTE")
+4 NEW IEN,XCOD,INACTIVE,DELDT,ADDDT
+5 SET IEN=0
+6 FOR
SET IEN=$ORDER(^ICPT(IEN))
IF IEN'=+IEN
QUIT
Begin DoDot:1
+7 ;actual CPT code
SET ACPTCD=$PIECE($GET(^ICPT(IEN,0)),"^")
+8 IF ACPTCD=""
SET ^ACPTEMP("ICPTE",IEN,0)="NO CPT CODE"
QUIT
+9 ;what IEN into tmp file is
SET ACPTIEN=$ORDER(^ACPTMP("B",ACPTCD,0))
+10 IF ACPTIEN=""
SET ^ACPTEMP("ICPTE",IEN,0)="NO CODE IN OUR FILE"
QUIT
+11 ;
+12 ; check if already has effective date multiple
+13 IF $ORDER(^ICPT(IEN,60,0))
QUIT
+14 ;
+15 ; do data checks
+16 SET XCOD=$PIECE($GET(^ACPTMP(ACPTIEN,0)),U)
+17 ;codes are different
IF XCOD'=$PIECE(^ICPT(IEN,0),U)
SET ^ACPTEMP("ICPTE",IEN,0)=XCOD
QUIT
+18 ;
+19 SET INACTIVE=$$GET1^DIQ(81,IEN,5,"I")
+20 IF INACTIVE
IF $$GET1^DIQ(81,IEN,8)=""
SET ^ACPTEMP("ICPTE",IEN,0)="NO DATE DELETED"
QUIT
+21 IF 'INACTIVE
IF $$GET1^DIQ(81,IEN,7,"I")<$$GET1^DIQ(81,IEN,8,"I")
SET ^ACPTEMP("ICPTE",IEN,0)="EARLIER ADD DATE"
QUIT
+22 ;
+23 ; add effective date data
+24 ;M ^ICPT(IEN,60)=^ACPTMP(ACPTIEN,60) ;IHS/SD/SDR 8/21/03
+25 ;IHS/SD/SDR 8/21/03
+26 SET ACPTCNT=0
+27 FOR
SET ACPTCNT=$ORDER(^ACPTMP(ACPTIEN,60,ACPTCNT))
IF ACPTCNT=""
QUIT
Begin DoDot:2
+28 SET ACPTEDT=$PIECE($GET(^ACPTMP(ACPTIEN,60,ACPTCNT,0)),"^")
+29 SET ACPTSTA=$PIECE($GET(^ACPTMP(ACPTIEN,60,ACPTCNT,0)),"^",2)
+30 SET X=ACPTEDT
+31 SET DA(1)=ACPTIEN
+32 SET DIC="^ICPT("_ACPTIEN_",60,"
+33 SET DIC(0)="LMX"
+34 SET DIC("P")=$PIECE(^DD(81,60,0),"^",2)
+35 SET DIC("DR")=".02///"_ACPTSTA
+36 DO ^DIC
End DoDot:2
+37 ;IHS/SD/SDR 8/21/03
+38 ;
+39 ; now fill in if no effective date added
+40 IF $ORDER(^ICPT(IEN,60,0))
QUIT
+41 IF INACTIVE
SET DELDT=$$GET1^DIQ(81,IEN,8,"I")
IF 'DELDT
QUIT
DO ADD(IEN,DELDT,0)
QUIT
+42 IF 'INACTIVE
SET ADDDT=$$GET1^DIQ(81,IEN,7,"I")
IF 'ADDDT
QUIT
DO ADD(IEN,ADDDT,1)
End DoDot:1
+43 ;
+44 ; now remove temp file and data
+45 NEW DIU,DIK
+46 SET DIU=90335
SET DIU(0)="DT"
+47 DO EN^DIU2
+48 ;
+49 ; add/edit/delete codes effective 7/1/2003
+50 DO START^ACPT23P2
+51 QUIT
+52 ;
ADD(IEN,DATE,STATUS) ; stuff effective date multiple
+1 ; IEN=CPT internal entry number
+2 ; DATE=effective date
+3 ; STATUS=1 for active, 0 for inactive
+4 NEW DD,DO,DIC,X,DA,DLAYGO
+5 SET DIC(0)="L"
SET DLAYGO=81.02
SET DIC("P")=$PIECE(^DD(81,60,0),U,2)
+6 SET DIC="^ICPT("_IEN_",60,"
+7 SET DA(1)=IEN
+8 SET X=DATE
+9 SET DIC("DR")=".02///"_STATUS
+10 DO FILE^DICN
+11 QUIT
+12 ;
RESET ;EP; delete 60 multiple to start over
+1 NEW IEN
+2 SET IEN=0
FOR
SET IEN=$ORDER(^ICPT(IEN))
IF 'IEN
QUIT
KILL ^ICPT(IEN,60)
+3 QUIT
