BPSJHLT ;BHAM ISC/LJF - HL7 Process Incoming MFN Messages ;05-NOV-2003
;;1.0;E CLAIMS MGMT ENGINE;**1,10,15,19,20**;JUN 2004;Build 27
;;Per VA Directive 6402, this routine should not be modified.
;
; Use of ERR^IBCNRHLU, HLT^IBCNRHLU, and MFK^IBCNRHLU supported by IA #6250
;
;**Program Description**
; This program will process incoming MFN messages and
; update the appropriate tables
;
; Direct entry not allowed
Q
;
PKY(PKYNM,PKYROOT,ADD) ;Lookup ien or add using PKYNM
N DA,DO,DIC,DIE,DINUM,DLAYGO,DTOUT,DUOUT,Y,X
I $G(PKYNM)]"",$G(PKYROOT)]"" S ADD=+$G(ADD)
E Q 0
S X=PKYNM,DIC=PKYROOT
I 'ADD S DIC(0)="X" D ^DIC
I ADD S DIC(0)="L",DLAYGO=PKYROOT D FILE^DICN
Q +Y
;
EN(HL) ; Entry Point
;
N BPSJACT,BPSJPKY,BPSJADT,BPSZPRER,BPSJROOT,PSIEN,APPACK
N ZPRS,BPSJSEG,HCT,ERRFLAG,NAFLG,NPFLG,SEG,MSG,MCT,FLN,FILE
N RBSTART,RBEND,RBCNT,ZPSNNAME,ZPRCNT,BPSETID,RCODE,MAXRX
N FS,CS,PSHTVER,NCPDPVER,NCPDPCK,BPSFILE,BPSJCNT,BPSJDEVN
N BPSJPROD,BPSJNAME,DIK,TCH
N AIEN,APIEN,D0,D,IEN,IBCNACT,DATAMFK,C,CMIEN,DATA,IBSEG
N DATAAP,DATABPS,DATACM,DATE,EPHARM,FIELDNO,FILENO,DI,I,MGRP
;
S FS=$G(HL("FS")) I FS="" S FS="|" ; field separator
S CS=$E($G(HL("ECH"))) I CS="" S CS="^" ; component separator
;
K ^TMP($J,"BPSJ-RBACK"),^TMP($J,"BPSJ-ERROR")
;
D INITZPRS^BPSJZPR(.ZPRS)
S BPSFILE=9002313.92,BPSJROOT=$$ROOT^DILFD(BPSFILE)
S RBSTART=100,RBEND=300,NCPDPCK=",51,D0,"
S (ZPSNNAME,BPSJPROD,NCPDPVER,PSHTVER,BPSJACT,BPSJADT,BPSJPKY)=""
;
; Initialize some Application Acknowledgement data
D DGAPPACK^BPSJACK
S APPACK("MSA",1)="AE" ; Assume error
S APPACK("MSA",2)=$G(HL("MID")) ; Message ID
S APPACK("MFA",4,1)="U" ; Set flag type of "unsuccessful event"
S APPACK("MFA",6)="ST"
S APPACK("MFI",6)="NE"
;
; Init encoding char array
S TCH("\F\")="|",TCH("\R\")="~"
S TCH("\E\")="\",TCH("\T\")="&"
;
; Variables BPSFLN1 and BPSFILE1 are defined in the calling routine
; BPSJHLI. Variables FLN and FILE are used externally in subsequent
; IBCNR* routines during segment processing.
I APP="TABLE" S FLN=BPSFLN1,FILE=BPSFILE1
;
S HCT=1,(MCT,NAFLG,NPFLG,ERRFLAG,ZPRCNT,MAXRX)=0
F D Q:'HCT I ERRFLAG Q
. K BPSJSEG S HCT=$O(^TMP($J,"BPSJHLI",HCT))
. D SPAR^BPSJUTL(.HL,.BPSJSEG,HCT) S SEG=$G(BPSJSEG(1))
. ;
. ; ; payer sheet detail (multiple)
. I SEG="ZPR" D Q ; Record #5+ (MSH is record #1)
.. ;
.. I ERRFLAG Q ; Fatal Error
.. S ZPRCNT=ZPRCNT+1,BPSETID=$G(BPSJSEG(2))
.. ;-If not numeric equivalent the warp engines are offline, Captain
.. I BPSETID'=ZPRCNT D FAKEREC(ZPRCNT)
.. D EN^BPSJZPR(PSIEN,.BPSJSEG,BPSJROOT,BPSFILE)
. ;
. I SEG="MFI" D Q ; Record #2
.. ;
.. I APP="TABLE" D Q
... K IBSEG M IBSEG=BPSJSEG
... ;
... ; Initialize MFK Message (Application Acknowledgement) variables
... ; Master File Identifier
... S DATAMFK("MFI-1")=$G(BPSJSEG(2))
... ;
... ; File-Level Event Code
... S DATAMFK("MFI-3")=$G(BPSJSEG(4))
.. ;
.. ;-Required Field checks
.. D ERRMSG(0,"MFI","1,2,3",.BPSJSEG)
.. ;
.. S APPACK("MFI",1,1)=$P($G(BPSJSEG(2)),CS)
.. S APPACK("MFI",1,2)=$P($G(BPSJSEG(2)),CS,2)
.. I APPACK("MFI",1,1)]"",APPACK("MFI",1,2)]""
.. E D
... ; hard code these for Version 1.0 of s/w
... D FILE^DID(BPSFILE,,"NAME","BPSJNAME")
... I APPACK("MFI",1,1)="" S APPACK("MFI",1,1)=BPSFILE
... I APPACK("MFI",1,2)="" S APPACK("MFI",1,2)=$G(BPSJNAME("NAME"))
... K BPSJNAME
... ;
.. S APPACK("MFI",3)=$G(BPSJSEG(4))
. ;
. I SEG="MFE" D Q ; Record #3
.. ;
.. I APP="TABLE" D Q
... K IBSEG M IBSEG=BPSJSEG
... I BPSFLN1="" S ERRFLAG=1,MSG(1)="File Number not found in MFN message" Q
... I '$$VFILE^DILFD(BPSFLN1) S ERRFLAG=1,MSG(1)="File "_BPSFLN1_" not found in the Data Dictionary" Q
... ;
... ; Initialize MFK Message (Application Acknowledgement) variables
... ; Record-Level Event Code
... S DATAMFK("MFE-1")=$G(BPSJSEG(2))
... ;
... ; Primary Key Value
... S DATAMFK("MFE-4")=$G(BPSJSEG(5))
... ;
... ; Primary Key Value Type
... S DATAMFK("MFE-5")=$G(BPSJSEG(6))
... ;
... ;Transfer control to IB for ePharmacy IB Table updates
... D HLT^IBCNRHLU ; IA# 6250
.. ;
.. ;-Required Field checks
.. D ERRMSG(0,"MFE","1,2,4,5",.BPSJSEG)
.. ;
.. S BPSJADT=$$NOW^XLFDT()
.. S (BPSJACT,APPACK("MFA",1))=$G(BPSJSEG(2)) ; Action type
.. I $L(BPSJACT)=3,"^MAD^MUP^MDC^"[(U_BPSJACT_U)
.. E D ERRMSG(1,"MFE","1^INVALID EVENT CODE")
.. ;
.. S APPACK("MFA",2)=$G(BPSJSEG(3)) ; MFN Control ID
.. ;
.. ; Old/Current Sheet name
.. S (BPSJPKY,APPACK("MFA",5))=$G(BPSJSEG(5))
.. S APPACK("MFA",4,2)="Payer Sheet "_BPSJPKY
.. S BPSJPKY=$$DECODE^BPSJZPR(BPSJPKY,.TCH)
.. ;
.. ;-Get ien using sheet name, if one exists
.. S PSIEN=$$PKY(BPSJPKY,BPSJROOT)
.. ;
.. I PSIEN=0 D ERRMSG(91,"Fileman error") Q
.. ;
.. I PSIEN>0 D ; Exists: save current data for rollback
... S APPACK("MFA",4,1)="P" ;Set flag type to "P"rior version
... M ^TMP($J,"BPSJ-RBACK",PSIEN)=^BPSF(9002313.92,PSIEN)
... ;-Kill appropriate existing Payer Sheet fields
... F RBCNT=RBSTART:10:RBEND K ^BPSF(9002313.92,PSIEN,RBCNT)
.. ;
.. ;-Create development sheet
.. I PSIEN<0 S BPSJCNT=0 F S BPSJCNT=1+BPSJCNT D Q:PSIEN>0
... S BPSJDEVN="BPSJ-DEV-"_$J_"-"_BPSJCNT
... S PSIEN=$$PKY(BPSJDEVN,BPSJROOT) ; see if dev sheet exists
... I PSIEN>-1 S PSIEN=0 Q
... S PSIEN=$$PKY(BPSJDEVN,BPSJROOT,1) ; add new one
.. ;
.. I PSIEN=0 D ERRMSG(92,"Fileman error") Q
.. ;
.. ;-Flag the sheet as being in development by this process
.. K DA,DIE,DR S DA=PSIEN,DIE=BPSJROOT
.. S DR="1.06////1."_$J ;FOR DEVELOPMENT
.. D ^DIE
. ;
. I APP="TABLE" D Q
.. Q:'HCT
.. K IBSEG M IBSEG=BPSJSEG
.. ; Transfer control on other segments
.. I ",ZCM,ZP0,ZPB,ZPL,ZPP,ZPT,"[(","_SEG_",") D HLT^IBCNRHLU ; IA# 6250
. ;
. ;payer sheet header
. I SEG="ZPS" D Q ; Record #4
.. ;
.. ;-Required Field checks
.. D ERRMSG(0,"ZPS","1,2,3,4,5,6,7",.BPSJSEG)
.. ;
.. ;-New sheet name, production status and Payer Sheet and NCPDP versions
.. S ZPSNNAME=$$DECODE^BPSJZPR($G(BPSJSEG(4)),.TCH) K TCH
.. I ZPSNNAME="" S ZPSNNAME=$G(BPSJPKY)
.. ;Cannot rename an existing worksheet to a different but already existing name BPS*1*10
.. I ZPSNNAME]"",ZPSNNAME'=$G(BPSJPKY),$$PKY(ZPSNNAME,BPSJROOT)]"" S ^TMP($J,"BPSJ-ERROR","ZPS",3)=""
.. S BPSJPROD=$G(BPSJSEG(8)) I BPSJPROD'="P" S BPSJPROD="T"
.. S PSHTVER=$G(BPSJSEG(5)) I PSHTVER'=(PSHTVER\1) S ^TMP($J,"BPSJ-ERROR","ZPS",4)=""
.. S NCPDPVER=$G(BPSJSEG(6)) I NCPDPVER=""!(NCPDPCK'[NCPDPVER) S ^TMP($J,"BPSJ-ERROR","ZPS",5)=""
;
I APP="TABLE" D Q
. I ERRFLAG D ERR^IBCNRHLU K ERRFLAG ; IA# 6250
. ;
. ; Send MFK Message (Application Acknowledgement)
. I HL("APAT")="AL",$G(EPHARM) D MFK^IBCNRHLU ; IA# 6250
. ;
. K ^TMP($J,"BPSJ-RBACK"),^TMP($J,"BPSJ-ERROR")
;
I '$D(^TMP($J,"BPSJ-ERROR")) D
. S APPACK("MFA",4,1)="S" ; flag success
. S DR=".01////"_ZPSNNAME ; set the name
. S DA=PSIEN,DIE=BPSJROOT D ^DIE
. ;
. I BPSJACT="MDC" S BPSJACT=0 ;Disabled
. E D I 'BPSJACT S BPSJACT=0
.. I BPSJPROD="P" S BPSJACT=3 ;Production
.. I BPSJPROD="T" S BPSJACT=2 ;Testing
. S DR="1.06////"_BPSJACT,DA=PSIEN,DIE=BPSJROOT D ^DIE
. ; NCPDP Version
. S DR="1.02////"_NCPDPVER,DA=PSIEN,DIE=BPSJROOT D ^DIE
. ; Payer Sheet Version
. S DR="1.14////"_PSHTVER,DA=PSIEN,DIE=BPSJROOT D ^DIE
E I $G(PSIEN) D ;-Roll back
. ;-Remove if no prior existence
. I $G(^TMP($J,"BPSJ-RBACK",PSIEN,0))="" D Q
.. S DIK=BPSJROOT,DA=PSIEN D ^DIK
. ;
. ; Restore old data
. S ^BPSF(9002313.92,PSIEN,0)=$G(^TMP($J,"BPSJ-RBACK",PSIEN,0))
. S ^BPSF(9002313.92,PSIEN,1)=$G(^TMP($J,"BPSJ-RBACK",PSIEN,1))
. F RBCNT=RBSTART:10:RBEND D
.. K ^BPSF(9002313.92,PSIEN,RBCNT)
.. M ^BPSF(9002313.92,PSIEN,RBCNT)=^TMP($J,"BPSJ-RBACK",PSIEN,RBCNT)
;
D APPACK^BPSJACK(.HL,.APPACK,PSIEN)
;
K ^TMP($J,"BPSJ-RBACK"),^TMP($J,"BPSJ-ERROR")
;
Q
;
FAKEREC(REF) ; Setup a fake Record ID (Set ID)
N IX
;
S REF=+$G(REF)
S IX=$G(BPSJSEG(2)),BPSJSEG(2)=REF
I IX="" D Q ; Missing
. S ^TMP($J,"BPSJ-ERROR","ZPR",REF,1)="V631-1,"_REF
;
I IX=+IX,IX'=0
E D Q ; Invalid
. S ^TMP($J,"BPSJ-ERROR","ZPR",REF,1)="V631-2,"_REF
;
; We have a valid numeric to work with, but:
;
; Duplicate
I $G(^TMP($J,"BPSJ-ERROR","ZPR",IX))=IX D Q
. S ^TMP($J,"BPSJ-ERROR","ZPR",REF,1)="V631-4,"_REF
;
; Out Of Sequence
S ^TMP($J,"BPSJ-ERROR","ZPR",REF,1)="V631-3,"_REF
S ^TMP($J,"BPSJ-ERROR","ZPR",REF)=IX
;
Q
;
ERRMSG(SPECIAL,SEG,REQFLDS,BPSJSEG) ;
N FCNT,FNO,FIELD,C
S C=",",SPECIAL=+$G(SPECIAL),SEG=$G(SEG),REQFLDS=$G(REQFLDS)
I 'SPECIAL D Q
. ;-Evaluate required fields for non ZPR segs
. S FNO=$J(REQFLDS,C)
. F FCNT=1:1:FNO S FIELD=$P(REQFLDS,C,FCNT) I FIELD D
.. ;-Set flag for empty required field
.. I $G(BPSJSEG(FIELD+1))="" S ^TMP($J,"BPSJ-ERROR",SEG,FIELD)=""
;
;-"Special" handler
I SPECIAL=1 D Q
. ;-Set flag that field contains invalid value
. S ^TMP($J,"BPSJ-ERROR",SEG,+REQFLDS)=REQFLDS
;
I SPECIAL>90 S ERRFLAG=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSJHLT 9208 printed Apr 09, 2024@20:56:37 Page 2
BPSJHLT ;BHAM ISC/LJF - HL7 Process Incoming MFN Messages ;05-NOV-2003
+1 ;;1.0;E CLAIMS MGMT ENGINE;**1,10,15,19,20**;JUN 2004;Build 27
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Use of ERR^IBCNRHLU, HLT^IBCNRHLU, and MFK^IBCNRHLU supported by IA #6250
+5 ;
+6 ;**Program Description**
+7 ; This program will process incoming MFN messages and
+8 ; update the appropriate tables
+9 ;
+10 ; Direct entry not allowed
+11 QUIT
+12 ;
PKY(PKYNM,PKYROOT,ADD) ;Lookup ien or add using PKYNM
+1 NEW DA,DO,DIC,DIE,DINUM,DLAYGO,DTOUT,DUOUT,Y,X
+2 IF $GET(PKYNM)]""
IF $GET(PKYROOT)]""
SET ADD=+$GET(ADD)
+3 IF '$TEST
QUIT 0
+4 SET X=PKYNM
SET DIC=PKYROOT
+5 IF 'ADD
SET DIC(0)="X"
DO ^DIC
+6 IF ADD
SET DIC(0)="L"
SET DLAYGO=PKYROOT
DO FILE^DICN
+7 QUIT +Y
+8 ;
EN(HL) ; Entry Point
+1 ;
+2 NEW BPSJACT,BPSJPKY,BPSJADT,BPSZPRER,BPSJROOT,PSIEN,APPACK
+3 NEW ZPRS,BPSJSEG,HCT,ERRFLAG,NAFLG,NPFLG,SEG,MSG,MCT,FLN,FILE
+4 NEW RBSTART,RBEND,RBCNT,ZPSNNAME,ZPRCNT,BPSETID,RCODE,MAXRX
+5 NEW FS,CS,PSHTVER,NCPDPVER,NCPDPCK,BPSFILE,BPSJCNT,BPSJDEVN
+6 NEW BPSJPROD,BPSJNAME,DIK,TCH
+7 NEW AIEN,APIEN,D0,D,IEN,IBCNACT,DATAMFK,C,CMIEN,DATA,IBSEG
+8 NEW DATAAP,DATABPS,DATACM,DATE,EPHARM,FIELDNO,FILENO,DI,I,MGRP
+9 ;
+10 ; field separator
SET FS=$GET(HL("FS"))
IF FS=""
SET FS="|"
+11 ; component separator
SET CS=$EXTRACT($GET(HL("ECH")))
IF CS=""
SET CS="^"
+12 ;
+13 KILL ^TMP($JOB,"BPSJ-RBACK"),^TMP($JOB,"BPSJ-ERROR")
+14 ;
+15 DO INITZPRS^BPSJZPR(.ZPRS)
+16 SET BPSFILE=9002313.92
SET BPSJROOT=$$ROOT^DILFD(BPSFILE)
+17 SET RBSTART=100
SET RBEND=300
SET NCPDPCK=",51,D0,"
+18 SET (ZPSNNAME,BPSJPROD,NCPDPVER,PSHTVER,BPSJACT,BPSJADT,BPSJPKY)=""
+19 ;
+20 ; Initialize some Application Acknowledgement data
+21 DO DGAPPACK^BPSJACK
+22 ; Assume error
SET APPACK("MSA",1)="AE"
+23 ; Message ID
SET APPACK("MSA",2)=$GET(HL("MID"))
+24 ; Set flag type of "unsuccessful event"
SET APPACK("MFA",4,1)="U"
+25 SET APPACK("MFA",6)="ST"
+26 SET APPACK("MFI",6)="NE"
+27 ;
+28 ; Init encoding char array
+29 SET TCH("\F\")="|"
SET TCH("\R\")="~"
+30 SET TCH("\E\")="\"
SET TCH("\T\")="&"
+31 ;
+32 ; Variables BPSFLN1 and BPSFILE1 are defined in the calling routine
+33 ; BPSJHLI. Variables FLN and FILE are used externally in subsequent
+34 ; IBCNR* routines during segment processing.
+35 IF APP="TABLE"
SET FLN=BPSFLN1
SET FILE=BPSFILE1
+36 ;
+37 SET HCT=1
SET (MCT,NAFLG,NPFLG,ERRFLAG,ZPRCNT,MAXRX)=0
+38 FOR
Begin DoDot:1
+39 KILL BPSJSEG
SET HCT=$ORDER(^TMP($JOB,"BPSJHLI",HCT))
+40 DO SPAR^BPSJUTL(.HL,.BPSJSEG,HCT)
SET SEG=$GET(BPSJSEG(1))
+41 ;
+42 ; ; payer sheet detail (multiple)
+43 ; Record #5+ (MSH is record #1)
IF SEG="ZPR"
Begin DoDot:2
+44 ;
+45 ; Fatal Error
IF ERRFLAG
QUIT
+46 SET ZPRCNT=ZPRCNT+1
SET BPSETID=$GET(BPSJSEG(2))
+47 ;-If not numeric equivalent the warp engines are offline, Captain
+48 IF BPSETID'=ZPRCNT
DO FAKEREC(ZPRCNT)
+49 DO EN^BPSJZPR(PSIEN,.BPSJSEG,BPSJROOT,BPSFILE)
End DoDot:2
QUIT
+50 ;
+51 ; Record #2
IF SEG="MFI"
Begin DoDot:2
+52 ;
+53 IF APP="TABLE"
Begin DoDot:3
+54 KILL IBSEG
MERGE IBSEG=BPSJSEG
+55 ;
+56 ; Initialize MFK Message (Application Acknowledgement) variables
+57 ; Master File Identifier
+58 SET DATAMFK("MFI-1")=$GET(BPSJSEG(2))
+59 ;
+60 ; File-Level Event Code
+61 SET DATAMFK("MFI-3")=$GET(BPSJSEG(4))
End DoDot:3
QUIT
+62 ;
+63 ;-Required Field checks
+64 DO ERRMSG(0,"MFI","1,2,3",.BPSJSEG)
+65 ;
+66 SET APPACK("MFI",1,1)=$PIECE($GET(BPSJSEG(2)),CS)
+67 SET APPACK("MFI",1,2)=$PIECE($GET(BPSJSEG(2)),CS,2)
+68 IF APPACK("MFI",1,1)]""
IF APPACK("MFI",1,2)]""
+69 IF '$TEST
Begin DoDot:3
+70 ; hard code these for Version 1.0 of s/w
+71 DO FILE^DID(BPSFILE,,"NAME","BPSJNAME")
+72 IF APPACK("MFI",1,1)=""
SET APPACK("MFI",1,1)=BPSFILE
+73 IF APPACK("MFI",1,2)=""
SET APPACK("MFI",1,2)=$GET(BPSJNAME("NAME"))
+74 KILL BPSJNAME
+75 ;
End DoDot:3
+76 SET APPACK("MFI",3)=$GET(BPSJSEG(4))
End DoDot:2
QUIT
+77 ;
+78 ; Record #3
IF SEG="MFE"
Begin DoDot:2
+79 ;
+80 IF APP="TABLE"
Begin DoDot:3
+81 KILL IBSEG
MERGE IBSEG=BPSJSEG
+82 IF BPSFLN1=""
SET ERRFLAG=1
SET MSG(1)="File Number not found in MFN message"
QUIT
+83 IF '$$VFILE^DILFD(BPSFLN1)
SET ERRFLAG=1
SET MSG(1)="File "_BPSFLN1_" not found in the Data Dictionary"
QUIT
+84 ;
+85 ; Initialize MFK Message (Application Acknowledgement) variables
+86 ; Record-Level Event Code
+87 SET DATAMFK("MFE-1")=$GET(BPSJSEG(2))
+88 ;
+89 ; Primary Key Value
+90 SET DATAMFK("MFE-4")=$GET(BPSJSEG(5))
+91 ;
+92 ; Primary Key Value Type
+93 SET DATAMFK("MFE-5")=$GET(BPSJSEG(6))
+94 ;
+95 ;Transfer control to IB for ePharmacy IB Table updates
+96 ; IA# 6250
DO HLT^IBCNRHLU
End DoDot:3
QUIT
+97 ;
+98 ;-Required Field checks
+99 DO ERRMSG(0,"MFE","1,2,4,5",.BPSJSEG)
+100 ;
+101 SET BPSJADT=$$NOW^XLFDT()
+102 ; Action type
SET (BPSJACT,APPACK("MFA",1))=$GET(BPSJSEG(2))
+103 IF $LENGTH(BPSJACT)=3
IF "^MAD^MUP^MDC^"[(U_BPSJACT_U)
+104 IF '$TEST
DO ERRMSG(1,"MFE","1^INVALID EVENT CODE")
+105 ;
+106 ; MFN Control ID
SET APPACK("MFA",2)=$GET(BPSJSEG(3))
+107 ;
+108 ; Old/Current Sheet name
+109 SET (BPSJPKY,APPACK("MFA",5))=$GET(BPSJSEG(5))
+110 SET APPACK("MFA",4,2)="Payer Sheet "_BPSJPKY
+111 SET BPSJPKY=$$DECODE^BPSJZPR(BPSJPKY,.TCH)
+112 ;
+113 ;-Get ien using sheet name, if one exists
+114 SET PSIEN=$$PKY(BPSJPKY,BPSJROOT)
+115 ;
+116 IF PSIEN=0
DO ERRMSG(91,"Fileman error")
QUIT
+117 ;
+118 ; Exists: save current data for rollback
IF PSIEN>0
Begin DoDot:3
+119 ;Set flag type to "P"rior version
SET APPACK("MFA",4,1)="P"
+120 MERGE ^TMP($JOB,"BPSJ-RBACK",PSIEN)=^BPSF(9002313.92,PSIEN)
+121 ;-Kill appropriate existing Payer Sheet fields
+122 FOR RBCNT=RBSTART:10:RBEND
KILL ^BPSF(9002313.92,PSIEN,RBCNT)
End DoDot:3
+123 ;
+124 ;-Create development sheet
+125 IF PSIEN<0
SET BPSJCNT=0
FOR
SET BPSJCNT=1+BPSJCNT
Begin DoDot:3
+126 SET BPSJDEVN="BPSJ-DEV-"_$JOB_"-"_BPSJCNT
+127 ; see if dev sheet exists
SET PSIEN=$$PKY(BPSJDEVN,BPSJROOT)
+128 IF PSIEN>-1
SET PSIEN=0
QUIT
+129 ; add new one
SET PSIEN=$$PKY(BPSJDEVN,BPSJROOT,1)
End DoDot:3
if PSIEN>0
QUIT
+130 ;
+131 IF PSIEN=0
DO ERRMSG(92,"Fileman error")
QUIT
+132 ;
+133 ;-Flag the sheet as being in development by this process
+134 KILL DA,DIE,DR
SET DA=PSIEN
SET DIE=BPSJROOT
+135 ;FOR DEVELOPMENT
SET DR="1.06////1."_$JOB
+136 DO ^DIE
End DoDot:2
QUIT
+137 ;
+138 IF APP="TABLE"
Begin DoDot:2
+139 if 'HCT
QUIT
+140 KILL IBSEG
MERGE IBSEG=BPSJSEG
+141 ; Transfer control on other segments
+142 ; IA# 6250
IF ",ZCM,ZP0,ZPB,ZPL,ZPP,ZPT,"[(","_SEG_",")
DO HLT^IBCNRHLU
End DoDot:2
QUIT
+143 ;
+144 ;payer sheet header
+145 ; Record #4
IF SEG="ZPS"
Begin DoDot:2
+146 ;
+147 ;-Required Field checks
+148 DO ERRMSG(0,"ZPS","1,2,3,4,5,6,7",.BPSJSEG)
+149 ;
+150 ;-New sheet name, production status and Payer Sheet and NCPDP versions
+151 SET ZPSNNAME=$$DECODE^BPSJZPR($GET(BPSJSEG(4)),.TCH)
KILL TCH
+152 IF ZPSNNAME=""
SET ZPSNNAME=$GET(BPSJPKY)
+153 ;Cannot rename an existing worksheet to a different but already existing name BPS*1*10
+154 IF ZPSNNAME]""
IF ZPSNNAME'=$GET(BPSJPKY)
IF $$PKY(ZPSNNAME,BPSJROOT)]""
SET ^TMP($JOB,"BPSJ-ERROR","ZPS",3)=""
+155 SET BPSJPROD=$GET(BPSJSEG(8))
IF BPSJPROD'="P"
SET BPSJPROD="T"
+156 SET PSHTVER=$GET(BPSJSEG(5))
IF PSHTVER'=(PSHTVER\1)
SET ^TMP($JOB,"BPSJ-ERROR","ZPS",4)=""
+157 SET NCPDPVER=$GET(BPSJSEG(6))
IF NCPDPVER=""!(NCPDPCK'[NCPDPVER)
SET ^TMP($JOB,"BPSJ-ERROR","ZPS",5)=""
End DoDot:2
QUIT
End DoDot:1
if 'HCT
QUIT
IF ERRFLAG
QUIT
+158 ;
+159 IF APP="TABLE"
Begin DoDot:1
+160 ; IA# 6250
IF ERRFLAG
DO ERR^IBCNRHLU
KILL ERRFLAG
+161 ;
+162 ; Send MFK Message (Application Acknowledgement)
+163 ; IA# 6250
IF HL("APAT")="AL"
IF $GET(EPHARM)
DO MFK^IBCNRHLU
+164 ;
+165 KILL ^TMP($JOB,"BPSJ-RBACK"),^TMP($JOB,"BPSJ-ERROR")
End DoDot:1
QUIT
+166 ;
+167 IF '$DATA(^TMP($JOB,"BPSJ-ERROR"))
Begin DoDot:1
+168 ; flag success
SET APPACK("MFA",4,1)="S"
+169 ; set the name
SET DR=".01////"_ZPSNNAME
+170 SET DA=PSIEN
SET DIE=BPSJROOT
DO ^DIE
+171 ;
+172 ;Disabled
IF BPSJACT="MDC"
SET BPSJACT=0
+173 IF '$TEST
Begin DoDot:2
+174 ;Production
IF BPSJPROD="P"
SET BPSJACT=3
+175 ;Testing
IF BPSJPROD="T"
SET BPSJACT=2
End DoDot:2
IF 'BPSJACT
SET BPSJACT=0
+176 SET DR="1.06////"_BPSJACT
SET DA=PSIEN
SET DIE=BPSJROOT
DO ^DIE
+177 ; NCPDP Version
+178 SET DR="1.02////"_NCPDPVER
SET DA=PSIEN
SET DIE=BPSJROOT
DO ^DIE
+179 ; Payer Sheet Version
+180 SET DR="1.14////"_PSHTVER
SET DA=PSIEN
SET DIE=BPSJROOT
DO ^DIE
End DoDot:1
+181 ;-Roll back
IF '$TEST
IF $GET(PSIEN)
Begin DoDot:1
+182 ;-Remove if no prior existence
+183 IF $GET(^TMP($JOB,"BPSJ-RBACK",PSIEN,0))=""
Begin DoDot:2
+184 SET DIK=BPSJROOT
SET DA=PSIEN
DO ^DIK
End DoDot:2
QUIT
+185 ;
+186 ; Restore old data
+187 SET ^BPSF(9002313.92,PSIEN,0)=$GET(^TMP($JOB,"BPSJ-RBACK",PSIEN,0))
+188 SET ^BPSF(9002313.92,PSIEN,1)=$GET(^TMP($JOB,"BPSJ-RBACK",PSIEN,1))
+189 FOR RBCNT=RBSTART:10:RBEND
Begin DoDot:2
+190 KILL ^BPSF(9002313.92,PSIEN,RBCNT)
+191 MERGE ^BPSF(9002313.92,PSIEN,RBCNT)=^TMP($JOB,"BPSJ-RBACK",PSIEN,RBCNT)
End DoDot:2
End DoDot:1
+192 ;
+193 DO APPACK^BPSJACK(.HL,.APPACK,PSIEN)
+194 ;
+195 KILL ^TMP($JOB,"BPSJ-RBACK"),^TMP($JOB,"BPSJ-ERROR")
+196 ;
+197 QUIT
+198 ;
FAKEREC(REF) ; Setup a fake Record ID (Set ID)
+1 NEW IX
+2 ;
+3 SET REF=+$GET(REF)
+4 SET IX=$GET(BPSJSEG(2))
SET BPSJSEG(2)=REF
+5 ; Missing
IF IX=""
Begin DoDot:1
+6 SET ^TMP($JOB,"BPSJ-ERROR","ZPR",REF,1)="V631-1,"_REF
End DoDot:1
QUIT
+7 ;
+8 IF IX=+IX
IF IX'=0
+9 ; Invalid
IF '$TEST
Begin DoDot:1
+10 SET ^TMP($JOB,"BPSJ-ERROR","ZPR",REF,1)="V631-2,"_REF
End DoDot:1
QUIT
+11 ;
+12 ; We have a valid numeric to work with, but:
+13 ;
+14 ; Duplicate
+15 IF $GET(^TMP($JOB,"BPSJ-ERROR","ZPR",IX))=IX
Begin DoDot:1
+16 SET ^TMP($JOB,"BPSJ-ERROR","ZPR",REF,1)="V631-4,"_REF
End DoDot:1
QUIT
+17 ;
+18 ; Out Of Sequence
+19 SET ^TMP($JOB,"BPSJ-ERROR","ZPR",REF,1)="V631-3,"_REF
+20 SET ^TMP($JOB,"BPSJ-ERROR","ZPR",REF)=IX
+21 ;
+22 QUIT
+23 ;
ERRMSG(SPECIAL,SEG,REQFLDS,BPSJSEG) ;
+1 NEW FCNT,FNO,FIELD,C
+2 SET C=","
SET SPECIAL=+$GET(SPECIAL)
SET SEG=$GET(SEG)
SET REQFLDS=$GET(REQFLDS)
+3 IF 'SPECIAL
Begin DoDot:1
+4 ;-Evaluate required fields for non ZPR segs
+5 SET FNO=$JUSTIFY(REQFLDS,C)
+6 FOR FCNT=1:1:FNO
SET FIELD=$PIECE(REQFLDS,C,FCNT)
IF FIELD
Begin DoDot:2
+7 ;-Set flag for empty required field
+8 IF $GET(BPSJSEG(FIELD+1))=""
SET ^TMP($JOB,"BPSJ-ERROR",SEG,FIELD)=""
End DoDot:2
End DoDot:1
QUIT
+9 ;
+10 ;-"Special" handler
+11 IF SPECIAL=1
Begin DoDot:1
+12 ;-Set flag that field contains invalid value
+13 SET ^TMP($JOB,"BPSJ-ERROR",SEG,+REQFLDS)=REQFLDS
End DoDot:1
QUIT
+14 ;
+15 IF SPECIAL>90
SET ERRFLAG=1
+16 QUIT
