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