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

ABSPOSJ1.m

Go to the documentation of this file. 
  1. ABSPOSJ1 ;IHS/SD/lwj - NCPDP 5.1 pre and post init for V1.0 patch 3 [ 10/31/2002  10:58 AM ]
  1.  ;;1.0;Pharmacy Point of Sale;**3,6,12,14,16,17,24,28,29,31,32,36,37,38,39,42,43,44,45,46,47,48**;Jun 21,2001;Build 27
  1.  ;
  1.  ; Pre and Post init routine use in absp0100.03k
  1.  ;------------------------------------------------------------------
  1.  ;
  1.  ; Pre and Post init routine to use in absp0100.06k
  1.  ;
  1.  ; Purpose of new subroutines:
  1.  ; These subroutines will be used to kill the ^ABSPF(9002313.91)
  1.  ; and ^ABSP(9002313.91) files. This will be done in preparation of KIDS
  1.  ; restoring the data portion of these files.  (As of January 2003 the
  1.  ; SAC mandates that all global kills and restores be done within Kids.)
  1.  ;
  1.  ;------------------------------------------------------------------
  1.  ;IHS/SD/lwj 6/9/05 patch 12
  1.  ; Added new entry point for patch 12 post init.  Subroutine
  1.  ; will update the ABSP INSURER file so anyone with Pp access can
  1.  ; add to the file.
  1.  ;------------------------------------------------------------------
  1.  ;IHS/SD/lwj 11/7/05 patch 14
  1.  ; Added a subroutine to add ABSP MEDICARE PART D ELIG CHK to the
  1.  ; ABSP MANAGER MENU.
  1.  ;------------------------------------------------------------------
  1.  ;IHS/SD/RLT - 2/22/06 - Patch 16
  1.  ; Added ABSP RPT MEDICARE PART D INS option to
  1.  ; ABSP MENU RPT CLAIM STATUS menu
  1.  ;------------------------------------------------------------------
  1.  ;IHS/SD/RLT - 6/13/06 - Patch 17
  1.  ; Added ABSP RPT MEDICARE PART D INS option to
  1.  ; ABSP MENU RPT CLAIM STATUS menu
  1.  ;------------------------------------------------------------------
  1.  ;IHS/SD/RLT = 02/26/08 - Patch 23
  1.  ; Update old Emdeon IP address 199.244.222.6 to DNS name
  1.  ; emdeonserver.ihs.gov which is pointing to 170.138.220.70
  1.  ;------------------------------------------------------------------
  1.  ;IHS/OIT/SCR = 09/22/08 - Patch 28
  1.  ; look for HELD claims in pre-init routines and print report if they are there
  1.  ; Remove file  ^ABSPHOLD in post-init routine
  1.  ; Remove outdated comments to get routine block size under 1500
  1.  ;  ;------------------------------------------------------------------
  1.  ;IHS/OIT/SCR = 02/06/09 - Patch 29
  1.  ; Created routine ABSPOSJ2.int to isolate patch 28 changes and shorten routine
  1.  Q
  1. PATCH6 ;EP - pre-init for absp0100.p6k
  1.  ; This subroutine is used to perform the preinits needed
  1.  ; for POS V1.0 patch 6.
  1.  D SAVE         ;patch 3 conversion
  1.  D FLDDEF       ;kill ABSPF(9002313.91 for new field definitions
  1.  D FORMAT        ;kill ABPSF(9002313.92 for new/updated formats
  1.  ;D HOLDCHK^ABSPOSJ2  ;IHS/OIT/SCR - 02/09/08 Patch 29 look for and release HELD claims
  1.  Q
  1. FLDDEF ;EP - pre-init for abps0100.p6k    
  1.  ;   Kill of ^ABSPF(9002313.91)  - ABSP NCPDP FIELD DEFS
  1.  ;   This file is killed so that updated field definitions can be loaded
  1.  ;   into the file.
  1.  K ^ABSPF(9002313.91)
  1.  Q
  1. FORMAT ;EP - pre-init for absp0100.p6k
  1.  ;   This file is killed so that updated formats can be loaded into
  1.  ;   the file
  1.  ;K ^ABSPF(9002313.92) ;OIT/PIERAN/RCS Patch 42
  1.  ;
  1.  Q
  1. SAVE ;EP - pre-init for abps0100.p3k
  1.  ; This subroutine will save any existing values found in the
  1.  ; 431, and 433-443 fields into a save global (^ABSPOSXX($J,"ABSPOSJ1")
  1.  ; This global will be used to hold the values while the data
  1.  ; dictionary redefines their storage location, and it will
  1.  ; then be used in the RESTORE subroutine of this program during the
  1.  ; post-init to restore the values to their new home.
  1.  ; ^ABSPOSXX($J,"ABSPOSJ1",ClmIEN,400,MedIEN,400)
  1.  ;   ClmIEN - IEN for the individual claims
  1.  ;   MedIEN - IEN for the medication subfile
  1.  ; first thing - see if the conversion has run before - if so, quit
  1.  Q:$$CKSETUP()
  1.  ;
  1.  N CLMIEN,MEDIEN,REC
  1.  S (CLMIEN,MEDIEN)=0
  1.  F  S CLMIEN=$O(^ABSPC(CLMIEN)) Q:'+CLMIEN  D
  1.  . D SAV320
  1.  . S MEDIEN=0
  1.  . F  S MEDIEN=$O(^ABSPC(CLMIEN,400,MEDIEN)) Q:'+MEDIEN  D
  1.  .. S REC=$G(^ABSPC(CLMIEN,400,MEDIEN,400))
  1.  .. Q:REC=""
  1.  .. D SAVREC
  1.  ;
  1.  Q
  1.  ;
  1. SAV320 ; Save the 320 field, since node 300 also hit its limits 
  1.  N OUTREC,FDA,MSG,VALUE
  1.  S VALUE=$P($G(^ABSPC(CLMIEN,300)),U,20)    ;grab 320
  1.  Q:VALUE=""
  1.  S OUTREC=VALUE_"^"
  1.  S FDA(9002313.02,CLMIEN_",",320)=""
  1.  D FILE^DIE("","FDA","MSG")
  1.  I $D(MSG) D LOG^ABSPOSL2("SAV320^ABSPOSJ1",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
  1.  S ^ABSPOSXX("ABSPOSJ1",CLMIEN,320)=OUTREC
  1.  Q
  1.  ;
  1. SAVREC ; Save the record
  1.  N OUTREC,I,FND
  1.  S FND=0     ;set to 1 if a value is found
  1.  S OUTREC="^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^"   ;start at 31
  1.  S OUTREC=OUTREC_$P(REC,U,31)_"^"    ;1st just field 431
  1.  I $P(REC,U,31)'="" D DELFLD(431)  ;if value - delete it
  1.  F I=33:1:43  D    ;now get 433- 443
  1.  . S OUTREC=OUTREC_"^"_$P(REC,U,I)    ;save it 
  1.  . I $P(REC,U,I)'="" D DELFLD(400+I)  ;delete it
  1.  S:FND ^ABSPOSXX("ABSPOSJ1",CLMIEN,400,MEDIEN,400)=OUTREC
  1.  Q
  1. DELFLD(FLDNUM) ;
  1.  N FDA,MSG
  1.  S FDA(9002313.0201,MEDIEN_","_CLMIEN_",",FLDNUM)=""
  1.  D FILE^DIE("","FDA","MSG")
  1.  I $D(MSG) D LOG^ABSPOSL2("DELFLD^ABSPOSJ1",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
  1.  S FND=1              ;we found at least 1
  1.  Q
  1. POST47 ; IHS/OIT/RCS 04/08/2014 Patch 47 Add the new ICD10 General default date
  1.  D DEF2^ABSPOSJ2
  1.  D POST46
  1.  Q
  1. POST46 ; IHS/OIT/RCS 11/28/2012 Patch 46 Add the Maximum Dollar Limit, Unsuppress Fields 147,384 for Medicare Part D plans
  1.  D DOL^ABSPOSJ2
  1.  D MCAR^ABSPOSJ2
  1.  D POST45
  1.  Q
  1. POST45 ; IHS/OIT/RCS 11/28/2012 Patch 45 Add the ICD10 General default date
  1.  D DEF^ABSPOSJ2
  1.  D POST44
  1.  Q
  1. POST44 ; IHS/OIT/RCS 8/31/2012 Patch 44 fix for DIALOUT field
  1.  D DIAL^ABSPOSJ2
  1.  D POST43
  1.  Q
  1. POST43 ; - IHS/OIT/RCS 3/2/2012 patch 43 run fix for errored reversals
  1.  D CLNREV^ABSPOSJ2
  1.  D POST42
  1.  Q
  1. POST42 ; - IHS/OIT/RAN 3/16/2011 patch 42 run conversion that switches over from formats to new Claims methodology
  1.  D EN^ABSPICNV
  1.  D POST39
  1.  Q
  1. POST39 ; - IHS/OIT/SCR 6/28/2010 patch 39 cleanup reject codes in response file
  1.  D CLNREJ^ABSPOSJ2
  1.  D POST38
  1.  Q
  1. POST38 ;EP - IHS/OIT/SCR 03/24/10 patch 38 mark options out of order if site not using IHS 3PB
  1.  ;IHS/OIT/CNI/SCR patch 39 060210 mark options as active if site IS using IHS 3PB..
  1.  N ABSPAR
  1.  S ABSPAR=$G(^ABSP(9002313.99,1,"A/R INTERFACE"))
  1.  I $P(ABSPAR,"^",1)'=3 D
  1.  .D OUT^XPDMENU("ABSP RPT TXN POSTING SUMMARY","OUT OF ORDER: IHS A/R NOT IN USE")
  1.  I $P(ABSPAR,"^",1)=3 D
  1.  .D OUT^XPDMENU("ABSP RPT TXN POSTING SUMMARY","")
  1.  ;
  1.  D POST37
  1.  Q
  1. POST37 ;EP - IHS/OIT/SCR 02/19/10 patch 37 mark options out of order if site not using IHS 3PB
  1.  ;IHS/OIT/CNI/SCR 060210 patch 39 mark options as active if site IS using IHS 3PB..
  1.  N ABSPAR
  1.  S ABSPAR=$G(^ABSP(9002313.99,1,"A/R INTERFACE"))
  1.  I $P(ABSPAR,"^",1)'=3 D
  1.  .D OUT^XPDMENU("ABSP RPT BAR PERIOD SUMMARY","OUT OF ORDER: IHS A/R NOT IN USE")
  1.  .D OUT^XPDMENU("ABSP RPT BARSTATRPT","OUT OF ORDER: IHS A/R NOT IN USE")
  1.  ;
  1.  I $P(ABSPAR,"^",1)=3 D
  1.  .D OUT^XPDMENU("ABSP RPT BAR PERIOD SUMMARY","")
  1.  .D OUT^XPDMENU("ABSP RPT BARSTATRPT","")
  1.  .;D POST36  ;IHS/OIT/CNI/SCR 060210 patch 3WRR WAS REMOVED FROM THE PACKAGE...SKIP THE POSTINIT ROUTINE TO ACTIVATE IT
  1.  .D POST31
  1.  Q
  1. POST36 ;EP - IHS/OIT/SCR 01/12/10 patch 36 mark option in order
  1.  D OUT^XPDMENU("ABSP RPT RECOVERED FROM RJCTN","")
  1.  D MES^XPDUTL("WRR Worked Rejection Report re-activated")
  1.  I $$DELETE^XPDMENU("ABSP MENU RPT CLAIM STATUS","ABSP RPT MEDICARE PART D INS") D MES^XPDUTL("MPD report removed from CLA menu")
  1.  ;E  D MES^XPDUTL("***could not remove MPD report from CLA menu****")
  1.  D POST31
  1.  Q
  1. POST31 ;EP - IHS/OIT/SCR 05/15/09 patch 31 added subroutine
  1.  ; Remove 'garbage strings' from returning message field of ABSP REPORT MASTER
  1.  N ABSP31
  1.  S ABSP31=$$CLNRPT()  ;RETURNS 1 IF NO CHANGS, 2 IF CHANGE
  1.  I ABSP31=2 D MES^XPDUTL("Coded Rejection Messages Found and purged from ABSP REPORT MASTER file")
  1.  D POST28
  1.  Q
  1.  ;IHS/OIT/SCR 09/22/08 Patch 28 - remove release any HELD claims START new code
  1. POST28 ;EP - IHS/OIT/SCR 09/22/08 ; added subroutine
  1.  ; If there are claims that are being held, release them for processing
  1.  N DIU,ABSPHIEN
  1.  S DIU="^DIC(9002313.2,",DIU(0)="" D EN^DIU2
  1.  K DIU
  1.  S ABSPHIEN=0
  1.  ;Shoudln't be any data left, and nodes should already be deleted, but clean up anyway
  1.  F  S ABSPHIEN=$O(^ABSPHOLD(ABSPHIEN)) Q:'+ABSPHIEN  K ^ABSPHOLD(ABSPHIEN)
  1.  K ^ABSPHOLD(0)
  1.  D POST24
  1.  Q
  1.  ;IHS/OIT/SCR 09/22/08 Patch 28-remove release any HELD claims END new code
  1. POST24 ;EP - 02/28/08 - Patch 24 - RLT
  1.  ; Update old Emdeon IP address 199.244.222.6 to DNS name
  1.  ; emdeonserver.ihs.gov which is pointing to 170.138.220.70
  1.  N DIALIEN,NEWIP,IP
  1.  S DIALIEN=$O(^ABSP(9002313.55,"B","ENVOY DIRECT VIA T1 LINE",0))
  1.  I 'DIALIEN D
  1.  . D MES^XPDUTL("ENVOY DIRECT VIA TO LINE NOT FOUND, NOT updated")
  1.  . D MES^XPDUTL("from 999.999.999.9 to emdeonserver.ihs.gov")
  1.  I DIALIEN D
  1.  . S NEWIP="emdeonserver.ihs.gov"
  1.  . S IP=$P($G(^ABSP(9002313.55,DIALIEN,"SERVER")),U)
  1.  . I IP'="199.244.222.6"&(IP'="emdeonserver.ihs.gov") D
  1.  .. D MES^XPDUTL("ENVOY DIRECT VIA TO LINE has NOT been updated")
  1.  .. D MES^XPDUTL("origninal IP is not 999.999.999.9")
  1.  .. D MES^XPDUTL("origninal IP is "_IP)
  1.  . I IP="emdeonserver.ihs.gov" D
  1.  .. D MES^XPDUTL("ENVOY DIRECT VIA TO LINE has all ready")
  1.  .. D MES^XPDUTL("been updated to emdeonserver.ihs.gov")
  1.  . I IP="199.244.222.6" D
  1.  .. D ^XBFMK      ;kill FileMan variables
  1.  .. S DIE="^ABSP(9002313.55,"
  1.  .. S DA=DIALIEN
  1.  .. S DR="2021.01///"_NEWIP
  1.  .. D ^DIE
  1.  .. S IP=$P($G(^ABSP(9002313.55,DIALIEN,"SERVER")),U)
  1.  .. I IP="emdeonserver.ihs.gov" D
  1.  ... D MES^XPDUTL("ENVOY DIRECT VIA TO LINE has been updated")
  1.  ... D MES^XPDUTL("from 999.999.999.9 to emdeonserver.ihs.gov")
  1.  .. I IP'="emdeonserver.ihs.gov" D
  1.  ... D MES^XPDUTL("ENVOY DIRECT VIA TO LINE has NOT been updated")
  1.  ... D MES^XPDUTL("from 999.999.999.9 to emdeonserver.ihs.gov")
  1.  D POST17  ;cumulative patches - let's call the rest
  1.  Q
  1. POST17 ;EP - 6/13/06 Patch 17 RLT
  1.  ;Adding ABSP RPT RX BILLING STATUS option to
  1.  ;ABSP MENU RPT SETUP menu
  1.  N ABSPMENU,ABSPOPT,ABSPSYN,ABSPORD,ABSPX
  1.  S ABSPMENU="ABSP MENU RPT SETUP"
  1.  S ABSPOPT="ABSP RPT RX BILLING STATUS"
  1.  S ABSPSYN="RXB"
  1.  S ABSPORD=25
  1.  S ABSPX=$$ADD^XPDMENU(ABSPMENU,ABSPOPT,ABSPSYN,ABSPORD)
  1.  D:ABSPX'=1 MES^XPDUTL("ABSP RPT MEDICARE PART D INS **NOT** added")
  1.  D POST16  ;cumulative patches - let's call the rest
  1.  Q
  1. POST16 ;EP - 2/22/06 Patch 16 RLT
  1.  ;Adding ABSP RPT MEDICARE PART D INS option to
  1.  ;ABSP MENU RPT CLAIM STATUS menu
  1.  N ABSPMENU,ABSPOPT,ABSPSYN,ABSPORD,ABSPX
  1.  S ABSPMENU="ABSP MENU RPT CLAIM STATUS"
  1.  S ABSPOPT="ABSP RPT MEDICARE PART D INS"
  1.  S ABSPSYN="MPD"
  1.  S ABSPORD=93
  1.  S ABSPX=$$ADD^XPDMENU(ABSPMENU,ABSPOPT,ABSPSYN,ABSPORD)
  1.  D:ABSPX'=1 MES^XPDUTL("ABSP RPT MEDICARE PART D INS **NOT** added")
  1.  D POST14  ;cumulative patches - let's call the rest
  1.  Q
  1. POST14 ;EP - 11/7/05 patch 14 lwj
  1.  ; need to add the menu option for the Medicare Part D
  1.  ; eligibility check to the menu
  1.  D
  1.  . N X,DIC,DLAYGO,Y,DA
  1.  . S DIC(0)="XZ"
  1.  . S DA(1)=$O(^DIC(19,"B","ABSP MENU RPT MAIN",0)) ;main option nbr
  1.  . S X="ABSP MEDICARE PART D ELIG CHK"
  1.  . S DIC="^DIC(19,"_DA(1)_",10,"
  1.  . D ^DIC
  1.  . ;
  1.  . I Y<1 D          ;no menu entry yet - let's add it
  1.  .. S DA=$O(^DIC(19,"B","ABSP MEDICARE PART D ELIG CHK",0)) ;item rec nbr
  1.  .. S DIC("P")=$P(^DD(19,10,0),"^",2) ;get menu sub file nbr
  1.  .. S DIC("DR")="2///ELIG" ;synonym
  1.  .. S X=DA
  1.  .. S DIC(0)="LMZ"
  1.  .. D FILE^DICN
  1.  D POST12  ;cumulative patches - let's call the rest
  1.  Q
  1. POST12 ;EP - 6/9/05 patch 12 lwj
  1.  ; From patch 12 forward we need to make sure the insurer file
  1.  ; can be access for update and addition by anyone with Pp access.
  1.  S ^DIC(9002313.4,0,"WR")="Pp"      ;WRITE access
  1.  S ^DIC(9002313.4,0,"LAYGO")="Pp"   ;LAYGO access
  1.  D POST
  1.  Q
  1. POST ;EP - This will be the entry point for the post init in patch    
  1.  ; 3 of Pharmacy Point of Sale Version 1.0.  It will do two 
  1.  ; things.  First, it will check to see if patch 2 was run 
  1.  ; First, it will call the routine created in Patch 2 that
  1.  ; creates the Cache entry in the ABSP Dial out file.  Secondly,
  1.  ; it will call the "RESTORE" subroutine in this program to
  1.  ; restore the values from the moves done in fields on the 
  1.  ; ABSP claims file in preparation of 5.1.
  1.  ; first thing - see if the conversion has run before - if so, quit
  1.  Q:$$CKSETUP()
  1.  D ^ABSPOSSC       ;create Cache entry in dial out (from Patch 2)
  1.  D RESTORE^ABSPOSJ2
  1.  D UPSETUP         ;log that the conversion is complete
  1.  Q
  1. MOVFLD(FLDNUM,VALUE) ;Adds the field back to it's new location
  1.  N FDA,MSG
  1.  Q:FLDNUM=432    ;don't need to move 432
  1.  S FDA(9002313.0201,MEDIEN_","_CLMIEN_",",FLDNUM)=VALUE
  1.  D FILE^DIE(,"FDA","MSG")
  1.  I $D(MSG) D LOG^ABSPOSL2("MOVFLD^ABSPOSJ1",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
  1.  Q
  1. UPSETUP ; This routine is called after the conversion to the claim file is 
  1.  ; completed.  It will update the "NCPDP51" node of the setup file
  1.  ; with today's date so that future patches will not need to
  1.  ; run the conversion again.
  1.  N DATE,FDA,MSG
  1.  D NOW^%DTC
  1.  S DATE=%
  1.  S FDA(9002313.99,"1,",5151)=DATE
  1.  D FILE^DIE(,"FDA","MSG")
  1.  I $D(MSG) D LOG^ABSPOSL2("UPSETUP^ABSPOSJ1",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
  1.  Q
  1. CKSETUP() ; This routine will check the setup file for the existance of the
  1.  ; NCPDP51 node in the setup file.  If it exists, then the conversion
  1.  ; has already been run, and we will exit the routine.
  1.  N CONV
  1.  S CONV=1           ;1 means the conversion has run
  1.  S:$P($G(^ABSP(9002313.99,1,"NCPDP51")),U)="" CONV=0
  1.  Q CONV
  1. CLNRPT()  ;This routine will remove 'garbage' strings from 
  1.  ; ABSP REPORT MASTER file for RELEASED DATES in past 90 days
  1.  ;
  1.  ;LOOP THROUGH ABSP REPORT MASTER for strings in RETURN MESSAGE that start and end with "&" 
  1.  ;as in &ECL;RC:300;&  OR CONTAIN THE STRING "SPH:mmc3" and replace these strings.
  1.  N ABSPSTRT,ABSPIEN,ABSPDATE,ABSPMSG,MSGTEXT,ABSPRTN
  1.  D NOW^%DTC
  1.  S DATE=%
  1.  S ABSPSTRT=DATE-91
  1.  S ABSPRTN=1 ;ASSSUME RETURN WITH NO REPLACEMENT
  1.  S ABSPDATE=ABSPSTRT
  1.  F  S ABSPDATE=$O(^ABSPECX("RPT","B",ABSPDATE)) Q:'ABSPDATE  D
  1.  .N ABSPIEN S ABSPIEN=0 F  S ABSPIEN=$O(^ABSPECX("RPT","B",ABSPDATE,ABSPIEN)) Q:'ABSPIEN  D
  1.  ..S ABSPMSG=$P($G(^ABSPECX("RPT",ABSPIEN,"M",0)),"^",4)
  1.  ..;IHS/OIT/SCR 061509 patch 32 -added next two lines to strip leading and ending ";"
  1.  ..I ($E(ABSPMSG,1,1)=";") S ABSPMSG=$E(ABSPMSG,2,$L(ABSPMSG))
  1.  ..I ($E(ABSPMSG,$L(ABSPMSG),$L(ABSPMSG))=";") S ABSPMSG=$E(ABSPMSG,1,$L(ABSPMSG)-1)
  1.  ..I ($E(ABSPMSG,1,1)="&")&($E(ABSPMSG,$L(ABSPMSG),$L(ABSPMSG))="&") S MSGTEXT(1)="**Converted Msg" ;IHS/OIT/SCR 05/15/09
  1.  ..I ABSPMSG["SPH:mmc3" S MSGTEXT(1)="**Converted Msg"   ;IHS/OIT/SCR 05/12/09
  1.  ..I $D(MSGTEXT) D
  1.  ...N FDA,MSG
  1.  ...S FDA(9002313.61,ABSPIEN,1300)="MSGTEXT"
  1.  ...D UPDATE^DIE(,"FDA",,"MSG")
  1.  ...I $D(MSG) D LOG^ABSPOSL2("CLNRPT^ABSPOSJ1",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
  1.  ...S ABSPRTN=2
  1.  ...Q
  1.  ..Q
  1.  .Q
  1.  Q ABSPRTN