BPSOSO2 ;BHAM ISC/FCS/DRS/DLF - NCPDP Override-Fman utils ;06/01/2004
;;1.0;E CLAIMS MGMT ENGINE;**1,3,5,10,11**;JUN 2004;Build 27
;;Per VHA Directive 2004-038, this routine should not be modified.
Q
; EDIT,EDITGEN are called from the menus in BPSOSO1,
; typically reached from the pharmacy package's call
; to OVERRIDE^BPSOSO
; GET511 called from BPSOSCD during claim construction
;
;IHS/SD/lwj 8/01/02 NCPDP 5.1 changes to GET511 subroutine
; Routine was changed to look at an exceptions list, if the
; field being processed is in the exceptions list it will
; create a "claim header" and "claim rx" entry. The reason
; for this is that several 300 range fields were moved to the
; claim rx area within the 5.1 segments creating duplicate flds.
; (i.e. the <402 and >402 rule is no longer valid)
;
; subroutine PRIORA added to handle the input of the prior
; authorization information at prescription creation time.
;
EDIT(IEN,FIELDNUM) ;
I '$D(FIELDNUM) D EDITGEN(IEN) Q
; Editing one field
N DIE,DA,DR,DIDEL,DTOUT,FIELDNAM
S DA=$$HASVALUE(IEN,FIELDNUM)
; Make sure the entry exists in the subfile.
; Create an empty one if necessary.
I 'DA S DA=$$SETVALUE(IEN,FIELDNUM,"")
; edit the value field in the subfile
S DIE="^BPS(9002313.511,"_IEN_",1,",DA(1)=IEN
S DR=.02_$TR($$FIELDNAM(FIELDNUM),""";~","")
D ^DIE
; If the value is null, then delete the entire FIELDNUM entry
I $$GETVALUE(IEN,FIELDNUM)="" D DELVALUE(IEN,FIELDNUM)
Q
;
EDITGEN(IEN) ; general edit
; First pass: quick & dirty Fileman ^DIE call
; Future: Screenman interface
N DIE,DA,DR,DIDEL,DTOUT
S DA=IEN,DIE=$$FILENUM,DR=1 D ^DIE
; And we need to delete any entries with null values
N A S A=0 F S A=$O(^BPS(9002313.511,IEN,1,A)) Q:'A D
. N X S X=^BPS(9002313.511,IEN,1,A,0)
. I $P(X,U,2)="" D
. . N FIELDNUM S FIELDNUM=$P(^BPSF(9002313.91,$P(X,U),0),U)
. . D DELVALUE(IEN,FIELDNUM)
Q
GET511(IEN,ARR101,ARR402) ;function, called from BPSOSCD - load arrays with data from IEN
;
N A,BPFLDNUM,C,F,HDRLST,MULTLST,TFLD,X
;
; Build exception lists
S HDRLST=",524,",MULTLST=",147,308,315,316,317,318,319,320,327,357,"
;
S A=0,C=0
F S A=$O(^BPS(9002313.511,IEN,1,A)) Q:'A D
. S X=^BPS(9002313.511,IEN,1,A,0)
. S F=$P(X,U) ; Field IEN, points to 9002313.91
. ; Store in either claim header or claim detail, based on field #
. ; Note that logic below will put 401 field in both header and detail
. S BPFLDNUM=+$$FIELDNUM(F)
. S TFLD=","_BPFLDNUM_","
. I BPFLDNUM<402!(HDRLST[TFLD) S @ARR101@(F)=$P(X,U,2)
. I BPFLDNUM>401!(MULTLST[TFLD) S @ARR402@(F)=$P(X,U,2)
. ;
. S C=C+1
;
Q C ; return count
;
; utilities
LOCK() L +^BPS(9002313.511,IEN):300 Q $T
;
UNLOCK L -^BPS(9002313.511,IEN) Q
;
FILENUM() Q 9002313.511 ; BPS NCPDP OVERRIDE (#9002313.511)
;
SUBFNUM() Q 9002313.5111 ; NCPDP FIELD SUB-FIELD^^.02^2
;
FLOCK() L +^BPS(9002313.511):300 Q $T
;
FUNLOCK L -^BPS(9002313.511) Q
;
FIELDIEN(FIELDNUM) ; function, ien of BPS NCPDP FIELD DEFS (#9002313.91) Data Dictionary field
Q $$FIND1^DIC(9002313.91,,,FIELDNUM)
;
FIELDNAM(FIELDNUM) ; function, name of a 9002313.91 NCPDP Data Dictionary field
Q $$GET1^DIQ(9002313.91,$$FIELDIEN(FIELDNUM),.03)
;
; for IEN in BPS NCPDP FIELD DEFS (#9002313.91) return external #
FIELDNUM(IEN91) Q $P($G(^BPSF(9002313.91,IEN91,0)),U)
;
NEW() ;EP - function, create new entry in 9002313.511
F Q:$$FLOCK Q:'$$IMPOSS^BPSOSUE("L","RTI","interlock on new Override record creation",,"NEW",$T(+0))
N FLAGS,FDA,IEN,MSG,FN,X,NEWREC S FN=$$FILENUM
D NEW1
D FUNLOCK
Q NEWREC
;
NEW1 ;
S FDA(FN,"+1,",.01)=$O(^BPS(FN,"B",999999999999),-1)+1
D UPDATE^DIE(,"FDA","IEN","MSG")
I $D(MSG) D G NEW1:$$IMPOSS^BPSOSUE("FM","TRI","UPDATE^DIE failed",,"NEW1",$T(+0))
. D ZWRITE^BPSOS("FDA","IEN","MSG")
. K MSG
S NEWREC=IEN(1)
NEW2 ;
S FDA(FN,NEWREC_",",.02)="NOW"
D FILE^DIE("E","FDA","MSG")
Q:'$D(MSG) ; success
G NEW2:$$IMPOSS^BPSOSUE("FM","TRI","FILE^DIE failed",,"NEW2",$T(+0))
Q
;
HASVALUE(IEN,FIELDNUM) ; function, does the FIELDNUM have an override value?
; returns IEN into the subfile
Q $$FIND1^DIC($$SUBFNUM,","_IEN_",",,FIELDNUM)
;
GETVALUE(IEN,FIELDNUM) ; function, return currently-set override value for given FIELDNUM
N X S X=$$HASVALUE(IEN,FIELDNUM) I 'X Q ""
Q $$GET1^DIQ($$SUBFNUM,X_","_IEN_",",.02)
;
SETVALUE(IEN,FIELDNUM,VALUE) ; function, returns ien in subfile for this FIELDNUM
; Special case for the override file: if you're trying to set the
; field's value to "@", don't just delete the field value,
; which would leave the field defined with a null value.
; Instead, delete the entire override for the field.
; This prevents accidentally overriding a genuine value with null.
I "@"=VALUE D DELVALUE(IEN,FIELDNUM) Q ""
;
; But the usual case is just storing a value:
N FDA,MSG,IENS,IENARRAY
; check if there's already an entry for the fieldnum, if not put in a "+1,"
N ENTRY S ENTRY=$$HASVALUE(IEN,FIELDNUM) ; do we already have FIELDNUM?
I 'ENTRY S ENTRY="+1" ; create a new entry
;
S IENS=ENTRY_","_IEN_","
S FDA($$SUBFNUM,IENS,.01)=FIELDNUM
S FDA($$SUBFNUM,IENS,.02)=VALUE
D SETV1
I ENTRY="+1" S ENTRY=$G(IENARRAY(1))
Q ENTRY
;
SETV1 ;
D UPDATE^DIE("E","FDA","IENARRAY","MSG")
Q:'$D(MSG) ; success
K ^TMP("BPS",$J,"BPSOSO2",$J,"SETVALUE")
S ^TMP("BPS",$J,"BPSOSO2",$J,"SETVALUE")=$$ERRHDR
M ^TMP("BPS",$J,"BPSOSO2",$J,"SETVALUE","MSG")=MSG
I $D(IENARRAY) M ^TMP("BPS",$J,"BPSOSO2",$J,"SETVALUE","IENARRAY")=IENARRAY
D ZWRITE^BPSOS("FDA","IENARRAY","MSG")
G SETV1:$$IMPOSS^BPSOSUE("FM","TRI",,,"SETVALUE",$T(+0))
Q
;
DELVALUE(IEN,FIELDNUM) ;
N ENTRY S ENTRY=$$HASVALUE(IEN,FIELDNUM) Q:'ENTRY ; wasn't defined
N FDA,MSG
S FDA($$SUBFNUM,ENTRY_","_IEN_",",.01)="@"
DE5 D FILE^DIE("E","FDA","MSG")
Q:'$D(MSG) ; success
K ^TMP("BPS",$J,"BPSOSO2",$J,"DELVALUE")
S ^TMP("BPS",$J,"BPSOSO2",$J,"DELVALUE")=$$ERRHDR
D ZWRITE^BPSOS("IEN","FDA","MSG")
G DE5:$$IMPOSS^BPSOSUE("FM","TRI",,,"DELVALUE",$T(+0))
Q
;
ERRHDR() Q "ERROR AT $H="_$H_" FOR $J="_$J
;
SEE(IEN) N TMP M TMP=^BPS($$FILENUM,IEN) D ZWRITE^BPSOS("TMP") Q ; debugging
;
PRIORA(IEN) ;IHS/SD/lwj 9/3/02 Prior Authorization
; used to populate fields 461, 462 and 416. 416 will be created based on the input into fields 461, and 462.
;
N FIELDNUM
;
S FIELDNUM=461 ; 461-EU Prior Authorization Type Code
D EDIT(IEN,FIELDNUM)
S FIELDNUM=462 ; 462-EV Prior Authorization Number Submitted
D EDIT(IEN,FIELDNUM)
;
; combine field 461 and 462 to create 416-DG Prior Authorization/Medical Certification Code And Number
;
N VAL461,VAL462,VAL416,DA
S VAL461=$$GETVALUE(IEN,461)
S VAL462=$$GETVALUE(IEN,462)
S VAL416=VAL461_VAL462
Q:VAL416=""
;
S DA=$$SETVALUE(IEN,416,"")
S:$G(DA)'="" DA=$$SETVALUE(IEN,416,VAL416)
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSOSO2 6945 printed Dec 13, 2024@01:51:49 Page 2
BPSOSO2 ;BHAM ISC/FCS/DRS/DLF - NCPDP Override-Fman utils ;06/01/2004
+1 ;;1.0;E CLAIMS MGMT ENGINE;**1,3,5,10,11**;JUN 2004;Build 27
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ; EDIT,EDITGEN are called from the menus in BPSOSO1,
+5 ; typically reached from the pharmacy package's call
+6 ; to OVERRIDE^BPSOSO
+7 ; GET511 called from BPSOSCD during claim construction
+8 ;
+9 ;IHS/SD/lwj 8/01/02 NCPDP 5.1 changes to GET511 subroutine
+10 ; Routine was changed to look at an exceptions list, if the
+11 ; field being processed is in the exceptions list it will
+12 ; create a "claim header" and "claim rx" entry. The reason
+13 ; for this is that several 300 range fields were moved to the
+14 ; claim rx area within the 5.1 segments creating duplicate flds.
+15 ; (i.e. the <402 and >402 rule is no longer valid)
+16 ;
+17 ; subroutine PRIORA added to handle the input of the prior
+18 ; authorization information at prescription creation time.
+19 ;
EDIT(IEN,FIELDNUM) ;
+1 IF '$DATA(FIELDNUM)
DO EDITGEN(IEN)
QUIT
+2 ; Editing one field
+3 NEW DIE,DA,DR,DIDEL,DTOUT,FIELDNAM
+4 SET DA=$$HASVALUE(IEN,FIELDNUM)
+5 ; Make sure the entry exists in the subfile.
+6 ; Create an empty one if necessary.
+7 IF 'DA
SET DA=$$SETVALUE(IEN,FIELDNUM,"")
+8 ; edit the value field in the subfile
+9 SET DIE="^BPS(9002313.511,"_IEN_",1,"
SET DA(1)=IEN
+10 SET DR=.02_$TRANSLATE($$FIELDNAM(FIELDNUM),""";~","")
+11 DO ^DIE
+12 ; If the value is null, then delete the entire FIELDNUM entry
+13 IF $$GETVALUE(IEN,FIELDNUM)=""
DO DELVALUE(IEN,FIELDNUM)
+14 QUIT
+15 ;
EDITGEN(IEN) ; general edit
+1 ; First pass: quick & dirty Fileman ^DIE call
+2 ; Future: Screenman interface
+3 NEW DIE,DA,DR,DIDEL,DTOUT
+4 SET DA=IEN
SET DIE=$$FILENUM
SET DR=1
DO ^DIE
+5 ; And we need to delete any entries with null values
+6 NEW A
SET A=0
FOR
SET A=$ORDER(^BPS(9002313.511,IEN,1,A))
if 'A
QUIT
Begin DoDot:1
+7 NEW X
SET X=^BPS(9002313.511,IEN,1,A,0)
+8 IF $PIECE(X,U,2)=""
Begin DoDot:2
+9 NEW FIELDNUM
SET FIELDNUM=$PIECE(^BPSF(9002313.91,$PIECE(X,U),0),U)
+10 DO DELVALUE(IEN,FIELDNUM)
End DoDot:2
End DoDot:1
+11 QUIT
GET511(IEN,ARR101,ARR402) ;function, called from BPSOSCD - load arrays with data from IEN
+1 ;
+2 NEW A,BPFLDNUM,C,F,HDRLST,MULTLST,TFLD,X
+3 ;
+4 ; Build exception lists
+5 SET HDRLST=",524,"
SET MULTLST=",147,308,315,316,317,318,319,320,327,357,"
+6 ;
+7 SET A=0
SET C=0
+8 FOR
SET A=$ORDER(^BPS(9002313.511,IEN,1,A))
if 'A
QUIT
Begin DoDot:1
+9 SET X=^BPS(9002313.511,IEN,1,A,0)
+10 ; Field IEN, points to 9002313.91
SET F=$PIECE(X,U)
+11 ; Store in either claim header or claim detail, based on field #
+12 ; Note that logic below will put 401 field in both header and detail
+13 SET BPFLDNUM=+$$FIELDNUM(F)
+14 SET TFLD=","_BPFLDNUM_","
+15 IF BPFLDNUM<402!(HDRLST[TFLD)
SET @ARR101@(F)=$PIECE(X,U,2)
+16 IF BPFLDNUM>401!(MULTLST[TFLD)
SET @ARR402@(F)=$PIECE(X,U,2)
+17 ;
+18 SET C=C+1
End DoDot:1
+19 ;
+20 ; return count
QUIT C
+21 ;
+22 ; utilities
LOCK() LOCK +^BPS(9002313.511,IEN):300
QUIT $TEST
+1 ;
UNLOCK LOCK -^BPS(9002313.511,IEN)
QUIT
+1 ;
FILENUM() ; BPS NCPDP OVERRIDE (#9002313.511)
QUIT 9002313.511
+1 ;
SUBFNUM() ; NCPDP FIELD SUB-FIELD^^.02^2
QUIT 9002313.5111
+1 ;
FLOCK() LOCK +^BPS(9002313.511):300
QUIT $TEST
+1 ;
FUNLOCK LOCK -^BPS(9002313.511)
QUIT
+1 ;
FIELDIEN(FIELDNUM) ; function, ien of BPS NCPDP FIELD DEFS (#9002313.91) Data Dictionary field
+1 QUIT $$FIND1^DIC(9002313.91,,,FIELDNUM)
+2 ;
FIELDNAM(FIELDNUM) ; function, name of a 9002313.91 NCPDP Data Dictionary field
+1 QUIT $$GET1^DIQ(9002313.91,$$FIELDIEN(FIELDNUM),.03)
+2 ;
+3 ; for IEN in BPS NCPDP FIELD DEFS (#9002313.91) return external #
FIELDNUM(IEN91) QUIT $PIECE($GET(^BPSF(9002313.91,IEN91,0)),U)
+1 ;
NEW() ;EP - function, create new entry in 9002313.511
+1 FOR
if $$FLOCK
QUIT
if '$$IMPOSS^BPSOSUE("L","RTI","interlock on new Override record creation",,"NEW",$TEXT(+0))
QUIT
+2 NEW FLAGS,FDA,IEN,MSG,FN,X,NEWREC
SET FN=$$FILENUM
+3 DO NEW1
+4 DO FUNLOCK
+5 QUIT NEWREC
+6 ;
NEW1 ;
+1 SET FDA(FN,"+1,",.01)=$ORDER(^BPS(FN,"B",999999999999),-1)+1
+2 DO UPDATE^DIE(,"FDA","IEN","MSG")
+3 IF $DATA(MSG)
Begin DoDot:1
+4 DO ZWRITE^BPSOS("FDA","IEN","MSG")
+5 KILL MSG
End DoDot:1
if $$IMPOSS^BPSOSUE("FM","TRI","UPDATE^DIE failed",,"NEW1",$TEXT(+0))
GOTO NEW1
+6 SET NEWREC=IEN(1)
NEW2 ;
+1 SET FDA(FN,NEWREC_",",.02)="NOW"
+2 DO FILE^DIE("E","FDA","MSG")
+3 ; success
if '$DATA(MSG)
QUIT
+4 if $$IMPOSS^BPSOSUE("FM","TRI","FILE^DIE failed",,"NEW2",$TEXT(+0))
GOTO NEW2
+5 QUIT
+6 ;
HASVALUE(IEN,FIELDNUM) ; function, does the FIELDNUM have an override value?
+1 ; returns IEN into the subfile
+2 QUIT $$FIND1^DIC($$SUBFNUM,","_IEN_",",,FIELDNUM)
+3 ;
GETVALUE(IEN,FIELDNUM) ; function, return currently-set override value for given FIELDNUM
+1 NEW X
SET X=$$HASVALUE(IEN,FIELDNUM)
IF 'X
QUIT ""
+2 QUIT $$GET1^DIQ($$SUBFNUM,X_","_IEN_",",.02)
+3 ;
SETVALUE(IEN,FIELDNUM,VALUE) ; function, returns ien in subfile for this FIELDNUM
+1 ; Special case for the override file: if you're trying to set the
+2 ; field's value to "@", don't just delete the field value,
+3 ; which would leave the field defined with a null value.
+4 ; Instead, delete the entire override for the field.
+5 ; This prevents accidentally overriding a genuine value with null.
+6 IF "@"=VALUE
DO DELVALUE(IEN,FIELDNUM)
QUIT ""
+7 ;
+8 ; But the usual case is just storing a value:
+9 NEW FDA,MSG,IENS,IENARRAY
+10 ; check if there's already an entry for the fieldnum, if not put in a "+1,"
+11 ; do we already have FIELDNUM?
NEW ENTRY
SET ENTRY=$$HASVALUE(IEN,FIELDNUM)
+12 ; create a new entry
IF 'ENTRY
SET ENTRY="+1"
+13 ;
+14 SET IENS=ENTRY_","_IEN_","
+15 SET FDA($$SUBFNUM,IENS,.01)=FIELDNUM
+16 SET FDA($$SUBFNUM,IENS,.02)=VALUE
+17 DO SETV1
+18 IF ENTRY="+1"
SET ENTRY=$GET(IENARRAY(1))
+19 QUIT ENTRY
+20 ;
SETV1 ;
+1 DO UPDATE^DIE("E","FDA","IENARRAY","MSG")
+2 ; success
if '$DATA(MSG)
QUIT
+3 KILL ^TMP("BPS",$JOB,"BPSOSO2",$JOB,"SETVALUE")
+4 SET ^TMP("BPS",$JOB,"BPSOSO2",$JOB,"SETVALUE")=$$ERRHDR
+5 MERGE ^TMP("BPS",$JOB,"BPSOSO2",$JOB,"SETVALUE","MSG")=MSG
+6 IF $DATA(IENARRAY)
MERGE ^TMP("BPS",$JOB,"BPSOSO2",$JOB,"SETVALUE","IENARRAY")=IENARRAY
+7 DO ZWRITE^BPSOS("FDA","IENARRAY","MSG")
+8 if $$IMPOSS^BPSOSUE("FM","TRI",,,"SETVALUE",$TEXT(+0))
GOTO SETV1
+9 QUIT
+10 ;
DELVALUE(IEN,FIELDNUM) ;
+1 ; wasn't defined
NEW ENTRY
SET ENTRY=$$HASVALUE(IEN,FIELDNUM)
if 'ENTRY
QUIT
+2 NEW FDA,MSG
+3 SET FDA($$SUBFNUM,ENTRY_","_IEN_",",.01)="@"
DE5 DO FILE^DIE("E","FDA","MSG")
+1 ; success
if '$DATA(MSG)
QUIT
+2 KILL ^TMP("BPS",$JOB,"BPSOSO2",$JOB,"DELVALUE")
+3 SET ^TMP("BPS",$JOB,"BPSOSO2",$JOB,"DELVALUE")=$$ERRHDR
+4 DO ZWRITE^BPSOS("IEN","FDA","MSG")
+5 if $$IMPOSS^BPSOSUE("FM","TRI",,,"DELVALUE",$TEXT(+0))
GOTO DE5
+6 QUIT
+7 ;
ERRHDR() QUIT "ERROR AT $H="_$HOROLOG_" FOR $J="_$JOB
+1 ;
SEE(IEN) ; debugging
NEW TMP
MERGE TMP=^BPS($$FILENUM,IEN)
DO ZWRITE^BPSOS("TMP")
QUIT
+1 ;
PRIORA(IEN) ;IHS/SD/lwj 9/3/02 Prior Authorization
+1 ; used to populate fields 461, 462 and 416. 416 will be created based on the input into fields 461, and 462.
+2 ;
+3 NEW FIELDNUM
+4 ;
+5 ; 461-EU Prior Authorization Type Code
SET FIELDNUM=461
+6 DO EDIT(IEN,FIELDNUM)
+7 ; 462-EV Prior Authorization Number Submitted
SET FIELDNUM=462
+8 DO EDIT(IEN,FIELDNUM)
+9 ;
+10 ; combine field 461 and 462 to create 416-DG Prior Authorization/Medical Certification Code And Number
+11 ;
+12 NEW VAL461,VAL462,VAL416,DA
+13 SET VAL461=$$GETVALUE(IEN,461)
+14 SET VAL462=$$GETVALUE(IEN,462)
+15 SET VAL416=VAL461_VAL462
+16 if VAL416=""
QUIT
+17 ;
+18 SET DA=$$SETVALUE(IEN,416,"")
+19 if $GET(DA)'=""
SET DA=$$SETVALUE(IEN,416,VAL416)
+20 ;
+21 QUIT
+22 ;
