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

ABSPOSO2.m

Go to the documentation of this file. 
  1. ABSPOSO2 ; IHS/FCS/DRS - NCPDP Override-Fman utils ;  [ 09/03/2002  11:10 AM ]
  1.  ;;1.0;PHARMACY POINT OF SALE;**3,23,48**;JUN 21, 2001;Build 38
  1.  Q
  1.  ; EDIT,EDITGEN are called from the menus in ABSPOSO1,
  1.  ;   typically reached from the pharmacy package's call
  1.  ;   to OVERRIDE^ABSPOSO
  1.  ; GET511 is called from ABSPOSCD during claim construction
  1.  ;
  1.  ;IHS/SD/lwj 8/01/02  NCPDP 5.1 changes to GET511 subroutine
  1.  ; Routine was changed to look at an exceptions list, if the
  1.  ; field being processed is in the exceptions list it will
  1.  ; create a "claim header" and "claim rx" entry.  The reason
  1.  ; for this is that several 300 range fields were moved to the 
  1.  ; claim rx area within the 5.1 segments creating duplicate flds.
  1.  ; (i.e. the <402 and >402 rule is no longer valid)
  1.  ;
  1.  ; New routine (PRIORA) added to handle the input of the prior
  1.  ; authorization information at prescription creation time.
  1.  ;
  1.  ;IHS/SD/RLT - 06/21/07 - 10/18/07 - Patch 23
  1.  ; Added new tags NEW3 and NEW4 for DIAGNOSIS CODE
  1.  ;
  1. EDIT(IEN,FIELDNUM) ;
  1.  I '$D(FIELDNUM) D EDITGEN(IEN) Q
  1.  ; Editing one field
  1.  N DIE,DA,DR,DIDEL,DTOUT,FIELDNAM
  1.  S DA=$$HASVALUE(IEN,FIELDNUM)
  1.  ; Make sure the entry exists in the subfile.
  1.  ; Create an empty one if necessary.
  1.  I 'DA S DA=$$SETVALUE(IEN,FIELDNUM,"")
  1.  ; edit the value field in the subfile
  1.  S DIE="^ABSP(9002313.511,"_IEN_",1,",DA(1)=IEN
  1.  S DR=.02_$TR($$FIELDNAM(FIELDNUM),""";~","")
  1.  D ^DIE
  1.  ; If the value is null, then delete the entire FIELDNUM entry
  1.  I $$GETVALUE(IEN,FIELDNUM)="" D DELVALUE(IEN,FIELDNUM)
  1.  Q
  1. EDITGEN(IEN)       ; general edit
  1.  ; First pass:  quick & dirty Fileman ^DIE call
  1.  ; Future: Screenman interface
  1.  N DIE,DA,DR,DIDEL,DTOUT
  1.  S DA=IEN,DIE=$$FILENUM,DR=1 D ^DIE
  1.  ; And we need to delete any entries with null values
  1.  N A S A=0 F  S A=$O(^ABSP(9002313.511,IEN,1,A)) Q:'A  D
  1.  . N X S X=^ABSP(9002313.511,IEN,1,A,0)
  1.  . I $P(X,U,2)="" D
  1.  . . N FIELDNUM S FIELDNUM=$P(^ABSPF(9002313.91,$P(X,U),0),U)
  1.  . . D DELVALUE(IEN,FIELDNUM)
  1.  Q
  1. GET511(IEN,ARR101,ARR402) ;EP - from ABSPOSCD - load arrays with data from IEN
  1.  ; IHS/SD/lwj 8/1/02 altered for NCPDP 5.1 - must store some 
  1.  ; 300 range fields at the "header" and "detail" level due to 
  1.  ; restructing of 5.1 claim segments
  1.  ;
  1.  N A,C S A=0,C=0
  1.  N EXPTLST,TFLD                ;IHS/SD/lwj 8/1/02
  1.  ;
  1.  S EXPTLST=",308,315,316,317,318,319,320,327,"  ;IHS/SD/lwj 8/1/02
  1.  ;
  1.  F  S A=$O(^ABSP(9002313.511,IEN,1,A)) Q:'A  D
  1.  . N X S X=^ABSP(9002313.511,IEN,1,A,0)
  1.  . N F S F=$P(X,U) ; field IEN, points to 9002313.91
  1.  . ; store in either claim header or claim detail, based on field #
  1.  . I $$FIELDNUM(F)<402 S @ARR101@(F)=$P(X,U,2)
  1.  . E  S @ARR402@(F)=$P(X,U,2)
  1.  . ;
  1.  . ; IHS/SD/lwj 8/1/02  nxt 2 lns added to check for exception flds
  1.  . S TFLD=","_$$FIELDNUM(F)_","
  1.  . I EXPTLST[TFLD S @ARR402@(F)=$P(X,U,2)
  1.  . ;
  1.  . S C=C+1
  1.  Q:$Q C Q
  1.  ; 
  1.  ; Generalized utilities - good for everything, not just auth #
  1. LOCK() L +^ABSP(9002313.511,IEN):300 Q $T
  1. UNLOCK L -^ABSP(9002313.511,IEN) Q
  1. FILENUM()          Q 9002313.511
  1. SUBFNUM()          Q 9002313.5111
  1. FLOCK() L +^ABSP(9002313.511):300 Q $T
  1. FUNLOCK L -^ABSP(9002313.511) Q
  1. FIELDIEN(FIELDNUM) ; ien of a 9002313.91 NCPDP Data Dictionary field
  1.  Q $$FIND1^DIC(9002313.91,,,FIELDNUM)
  1. FIELDNAM(FIELDNUM) ; name of a 9002313.91 NCPDP Data Dictionary field
  1.  Q $$GET1^DIQ(9002313.91,$$FIELDIEN(FIELDNUM),.03)
  1.  ; given pointer to NCPDP Data Dictionary fields, return external #
  1. FIELDNUM(IEN91)    Q $P($G(^ABSPF(9002313.91,IEN91,0)),U)
  1. NEW() ;EP -  create new entry in 9002313.511
  1.  F  Q:$$FLOCK  Q:'$$IMPOSS^ABSPOSUE("L","RTI","interlock on new Override record creation",,"NEW",$T(+0))
  1.  N FLAGS,FDA,IEN,MSG,FN,X,NEWREC S FN=$$FILENUM
  1.  D NEW1
  1.  D FUNLOCK
  1.  Q NEWREC
  1. NEW1 ;EP  (from ABSPOSD2 and ABSPOSD3)
  1.  S FDA(FN,"+1,",.01)=$O(^ABSP(FN,"B",999999999999),-1)+1
  1.  D UPDATE^DIE(,"FDA","IEN","MSG")
  1.  I $D(MSG) D LOG^ABSPOSL2("NEW1^ABSPOSO2",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
  1.  I $D(MSG) D  G NEW1:$$IMPOSS^ABSPOSUE("FM","TRI","UPDATE^DIE failed",,"NEW1",$T(+0))
  1.  . D ZWRITE^ABSPOS("FDA","IEN","MSG")
  1.  . K MSG
  1.  S NEWREC=IEN(1)
  1. NEW2 ;
  1.  S FDA(FN,NEWREC_",",.02)="NOW"
  1.  D FILE^DIE("E","FDA","MSG")
  1.  I $D(MSG) D LOG^ABSPOSL2("NEW2^ABSPOSO2",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
  1.  ;Q:'$D(MSG)  ; success
  1.  G:$D(MSG) NEW2:$$IMPOSS^ABSPOSUE("FM","TRI","FILE^DIE failed",,"NEW2",$T(+0))
  1.  Q:FN'=9002313.491      ;quit if not DIAGNOSIS CODE - use for DUR too????
  1. NEW3 ;
  1.  S FDA(FN,NEWREC_",",.03)=RXI
  1.  D FILE^DIE(,"FDA","MSG")
  1.  I $D(MSG) D LOG^ABSPOSL2("NEW3^ABSPOSO2",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
  1.  G:$D(MSG) NEW3:$$IMPOSS^ABSPOSUE("FM","TRI","FILE^DIE failed",,"NEW3",$T(+0))
  1. NEW4 ;
  1.  S FDA(FN,NEWREC_",",.04)=RXR
  1.  D FILE^DIE(,"FDA","MSG")
  1.  I $D(MSG) D LOG^ABSPOSL2("NEW4^ABSPOSO2",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
  1.  G:$D(MSG) NEW4:$$IMPOSS^ABSPOSUE("FM","TRI","FILE^DIE failed",,"NEW4",$T(+0))
  1.  ;
  1.  Q
  1. HASVALUE(IEN,FIELDNUM)       ; does the FIELDNUM have an override value?
  1.  ; returns IEN into the subfile
  1.  Q $$FIND1^DIC($$SUBFNUM,","_IEN_",",,FIELDNUM)
  1. GETVALUE(IEN,FIELDNUM) ; return currently-set override value for given FIELDNUM
  1.  N X S X=$$HASVALUE(IEN,FIELDNUM) I 'X Q ""
  1.  Q $$GET1^DIQ($$SUBFNUM,X_","_IEN_",",.02)
  1. SETVALUE(IEN,FIELDNUM,VALUE) ;
  1.  ; can DO or $$; $$ = ien in subfile for this FIELDNUM
  1.  ; Special case for the override file:  if you're trying to set the
  1.  ; field's value to "@", don't just delete the field value,
  1.  ; which would leave the field defined with a null value.
  1.  ; Instead, delete the entire override for the field.
  1.  ; This prevents accidentally overriding a genuine value with null.
  1.  I "@"=VALUE D DELVALUE(IEN,FIELDNUM) Q:$Q "" Q
  1.  ; But the usual case is just storing a value:
  1.  N FDA,MSG,IENS,IENARRAY
  1.  ; Note:  I tried the "+?1,ien," method but it always created a new
  1.  ; entry, even when it meant creating duplicates.  So now we test to
  1.  ; see if there's already an entry for the fieldnum, and if not,
  1.  ; then we put in a "+1,"
  1.  N ENTRY S ENTRY=$$HASVALUE(IEN,FIELDNUM) ; do we already have FIELDNUM
  1.  I 'ENTRY S ENTRY="+1" ; if not, then create a new entry
  1.  S IENS=ENTRY_","_IEN_","
  1.  S FDA($$SUBFNUM,IENS,.01)=FIELDNUM
  1.  S FDA($$SUBFNUM,IENS,.02)=VALUE
  1.  D SETV1
  1.  I ENTRY="+1" S ENTRY=$G(IENARRAY(1))
  1.  Q:$Q ENTRY Q
  1. SETV1 ;
  1.  D UPDATE^DIE("E","FDA","IENARRAY","MSG")
  1.  I $D(MSG) D LOG^ABSPOSL2("SETV1^ABSPOSO2",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
  1.  Q:'$D(MSG)  ; success
  1.  K ^TMP("ABSP",$J,"ABSPOSO2",$J,"SETVALUE")
  1.  S ^TMP("ABSP",$J,"ABSPOSO2",$J,"SETVALUE")=$$ERRHDR
  1.  M ^TMP("ABSP",$J,"ABSPOSO2",$J,"SETVALUE","MSG")=MSG
  1.  I $D(IENARRAY) M ^TMP("ABSP",$J,"ABSPOSO2",$J,"SETVALUE","IENARRAY")=IENARRAY
  1.  D ZWRITE^ABSPOS("FDA","IENARRAY","MSG")
  1.  G SETV1:$$IMPOSS^ABSPOSUE("FM","TRI",,,"SETVALUE",$T(+0))
  1.  Q
  1. DELVALUE(IEN,FIELDNUM)       ;
  1.  N ENTRY S ENTRY=$$HASVALUE(IEN,FIELDNUM) Q:'ENTRY  ; wasn't defined
  1.  N FDA,MSG
  1.  S FDA($$SUBFNUM,ENTRY_","_IEN_",",.01)="@"
  1. DE5 D FILE^DIE("E","FDA","MSG")
  1.  I $D(MSG) D LOG^ABSPOSL2("DE5^ABSPOSO2",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
  1.  Q:'$D(MSG)  ; success
  1.  K ^TMP("ABSP",$J,"ABSPOSO2",$J,"DELVALUE")
  1.  S ^TMP("ABSP",$J,"ABSPOSO2",$J,"DELVALUE")=$$ERRHDR
  1.  D ZWRITE^ABSPOS("IEN","FDA","MSG")
  1.  G DE5:$$IMPOSS^ABSPOSUE("FM","TRI",,,"DELVALUE",$T(+0))
  1.  Q
  1. ERRHDR() Q "ERROR AT $H="_$H_" FOR $J="_$J
  1. SEE(IEN) N TMP M TMP=^ABSP($$FILENUM,IEN) D ZWRITE^ABSPOS("TMP") Q  ; debugging
  1.  ;
  1. PRIORA(IEN) ;IHS/SD/lwj 9/3/02 NCPDP 5.1 Changes - Prior Authorization 
  1.  ; We are still processing 5.1 and 3.2 claims, so we have to be able
  1.  ; to populate fields 461, 462 and 416.  416 will be created based
  1.  ; on the input into fields 461, and 462.
  1.  ;
  1.  N FIELDNUM
  1.  ;
  1.  S FIELDNUM=461              ;Prior authorization type code
  1.  D EDIT(IEN,FIELDNUM)
  1.  ;
  1.  S FIELDNUM=462              ;Prior authorization number submitted
  1.  D EDIT(IEN,FIELDNUM)
  1.  ;
  1.  ;now we combine field 461 and 462 to creat field 416
  1.  ;
  1.  N VAL461,VAL462,VAL416,DA
  1.  S (VAL461,VAL462,VAL416)=""
  1.  ;
  1.  S VAL461=$$GETVALUE(IEN,461)
  1.  S VAL462=$$GETVALUE(IEN,462)
  1.  S VAL416=VAL461_VAL462
  1.  Q:VAL416=""
  1.  ;
  1.  S DA=$$SETVALUE(IEN,416,"")
  1.  S:$G(DA)'="" DA=$$SETVALUE(IEN,416,VAL416)
  1.  ;
  1.  ;
  1.  Q