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

BPSOSO2.m

Go to the documentation of this file.
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
 ;