Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACPTLEX

ACPTLEX.m

Go to the documentation of this file. 
  1. 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 
  1.  ; New routine - 05/2003
  1.  ; Routine supplied by Linda Fels.  Minor mods have been made to
  1.  ; account for CPT files that may not be correct to get the most
  1.  ; hits and to account for a temp file specifically for errors.
  1.  ;
  1.  Q
  1.  ;
  1. BUILD ;EP; build temp global for transport
  1.  K ^ACPTMP("ICPT")
  1.  NEW X
  1.  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)
  1.  Q
  1.  ;
  1. PRE ;EP; remove old field 405.3 which uses 81.02 subfile number
  1.  NEW DIU,DIK
  1.  S DIU=81.02,DIU(0)="S" D EN^DIU2
  1.  S DIK="^DD(81,",DA=409.3,DA(1)=81 D ^DIK
  1.  Q
  1.  ;
  1. POST ;EP; build effective date multiple for ^ICPT global
  1.  ;I '$D(^ACPTMP("ICPT")) W !!,"NO DATA GLOBAL FOUND!" Q
  1.  ;K ^ACPTMP("ICPTE")     ;error global
  1.  K ^ACPTEMP("ICPTE")     ;error global  
  1.  NEW IEN,XCOD,INACTIVE,DELDT,ADDDT
  1.  S IEN=0
  1.  F  S IEN=$O(^ICPT(IEN)) Q:IEN'=+IEN  D
  1.  . S ACPTCD=$P($G(^ICPT(IEN,0)),"^")  ;actual CPT code
  1.  . I ACPTCD="" S ^ACPTEMP("ICPTE",IEN,0)="NO CPT CODE" Q
  1.  . S ACPTIEN=$O(^ACPTMP("B",ACPTCD,0))  ;what IEN into tmp file is
  1.  . I ACPTIEN="" S ^ACPTEMP("ICPTE",IEN,0)="NO CODE IN OUR FILE" Q
  1.  . ;
  1.  . ; check if already has effective date multiple
  1.  . Q:$O(^ICPT(IEN,60,0))
  1.  . ;
  1.  . ; do data checks
  1.  . S XCOD=$P($G(^ACPTMP(ACPTIEN,0)),U)
  1.  . I XCOD'=$P(^ICPT(IEN,0),U) S ^ACPTEMP("ICPTE",IEN,0)=XCOD Q   ;codes are different
  1.  . ;
  1.  . S INACTIVE=$$GET1^DIQ(81,IEN,5,"I")
  1.  . I INACTIVE,$$GET1^DIQ(81,IEN,8)="" S ^ACPTEMP("ICPTE",IEN,0)="NO DATE DELETED" Q
  1.  . I 'INACTIVE I $$GET1^DIQ(81,IEN,7,"I")<$$GET1^DIQ(81,IEN,8,"I") S ^ACPTEMP("ICPTE",IEN,0)="EARLIER ADD DATE" Q
  1.  . ;
  1.  . ; add effective date data
  1.  . ;M ^ICPT(IEN,60)=^ACPTMP(ACPTIEN,60)  ;IHS/SD/SDR 8/21/03
  1.  . ;IHS/SD/SDR 8/21/03
  1.  . S ACPTCNT=0
  1.  . F  S ACPTCNT=$O(^ACPTMP(ACPTIEN,60,ACPTCNT)) Q:ACPTCNT=""  D
  1.  .. S ACPTEDT=$P($G(^ACPTMP(ACPTIEN,60,ACPTCNT,0)),"^")
  1.  .. S ACPTSTA=$P($G(^ACPTMP(ACPTIEN,60,ACPTCNT,0)),"^",2)
  1.  .. S X=ACPTEDT
  1.  .. S DA(1)=ACPTIEN
  1.  .. S DIC="^ICPT("_ACPTIEN_",60,"
  1.  .. S DIC(0)="LMX"
  1.  .. S DIC("P")=$P(^DD(81,60,0),"^",2)
  1.  .. S DIC("DR")=".02///"_ACPTSTA
  1.  .. D ^DIC
  1.  . ;IHS/SD/SDR 8/21/03 
  1.  . ;
  1.  . ; now fill in if no effective date added
  1.  . Q:$O(^ICPT(IEN,60,0))
  1.  . I INACTIVE S DELDT=$$GET1^DIQ(81,IEN,8,"I") Q:'DELDT  D ADD(IEN,DELDT,0) Q
  1.  . I 'INACTIVE S ADDDT=$$GET1^DIQ(81,IEN,7,"I") Q:'ADDDT  D ADD(IEN,ADDDT,1)
  1.  ;
  1.  ; now remove temp file and data
  1.  NEW DIU,DIK
  1.  S DIU=90335,DIU(0)="DT"
  1.  D EN^DIU2
  1.  ;
  1.  ; add/edit/delete codes effective 7/1/2003
  1.  D START^ACPT23P2
  1.  Q
  1.  ;
  1. ADD(IEN,DATE,STATUS) ; stuff effective date multiple
  1.  ; IEN=CPT internal entry number
  1.  ; DATE=effective date
  1.  ; STATUS=1 for active, 0 for inactive
  1.  NEW DD,DO,DIC,X,DA,DLAYGO
  1.  S DIC(0)="L",DLAYGO=81.02,DIC("P")=$P(^DD(81,60,0),U,2)
  1.  S DIC="^ICPT("_IEN_",60,"
  1.  S DA(1)=IEN
  1.  S X=DATE
  1.  S DIC("DR")=".02///"_STATUS
  1.  D FILE^DICN
  1.  Q
  1.  ;
  1. RESET ;EP; delete 60 multiple to start over
  1.  NEW IEN
  1.  S IEN=0 F  S IEN=$O(^ICPT(IEN)) Q:'IEN  K ^ICPT(IEN,60)
  1.  Q