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

ABSPOSD2.m

Go to the documentation of this file. 
  1. ABSPOSD2 ; IHS/FCS/DRS - NCPDP DUR overrides ;  [ 09/03/2002  11:10 AM ]
  1.  ;;1.0;PHARMACY POINT OF SALE;**6,48**;JUN 21, 2001;Build 38
  1.  Q
  1.  ; EDIT is called from the menu 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.  ; This routine will be responsible for prompting for
  1.  ; and retaining the now repeating DUR segment values
  1.  ; for the NCPDP 5.1 format.
  1.  ;
  1. EDIT(DURIEN) ;EP called from ABSPOSO1 (menu option)
  1.  ;
  1.  ; Make sure the entry exists in the subfile.
  1.  ; Create an empty one if necessary.
  1.  ;
  1.  N DIE,DA,DR,DIDEL,DTOUT
  1.  S DA=DURIEN
  1.  S DIE=9002313.473
  1.  S DR=1
  1.  D ^DIE
  1.  ;
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. NEW() ;EP -  create new entry in 9002313.473
  1.  F  Q:$$FLOCK  Q:'$$IMPOSS^ABSPOSUE("L","RTI","interlock on new DUR rec create",,"NEW",$T(+0))
  1.  ;
  1.  N FLAGS,FDA,IEN,MSG,FN,X,NEWREC
  1.  S FN=9002313.473
  1.  D NEW1^ABSPOSO2
  1.  D FUNLOCK
  1.  ;
  1.  Q NEWREC
  1.  ;
  1.  ;
  1. CHKDUR(DURIEN) ;EP this should be the last step - we
  1.  ; need to check the DUR entry, if nothing was input
  1.  ; let's get rid of it.
  1.  ;
  1.  N SUBR,FNDREC
  1.  ;
  1.  S SUBR=0    ;starting point for review
  1.  S FNDREC=1  ;assume we need to delete-reset if we find values
  1.  F  S SUBR=$O(^ABSP(9002313.473,DURIEN,1,SUBR)) Q:'+SUBR  D
  1.  . N CHKR
  1.  . S CHKR=""
  1.  . S CHKR=$TR($P($G(^ABSP(9002313.473,DURIEN,1,SUBR,0)),U,2,7),"^")
  1.  . S:CHKR'="" FNDREC=0
  1.  . D:CHKR="" DELSUB(DURIEN,SUBR)
  1.  ;
  1.  I FNDREC D
  1.  . D DELREC(DURIEN)
  1.  . S DURIEN=""
  1.  ;
  1.  Q DURIEN
  1.  ;
  1. DELSUB(DLIEN,DLSUB) ; delete subrecord - no valid information
  1.  ;
  1.  N FDA,MSG
  1.  ;
  1.  S FDA(9002313.4731,DLSUB_","_DLIEN_",",.01)="@"
  1. DE3 D FILE^DIE("E","FDA","MSG")     ;delete the record
  1.  Q:'$D(MSG)   ;successful deletion
  1.  I $D(MSG) D LOG^ABSPOSL2("DE3^ABSPOSD2",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
  1.  ;
  1.  ; delete unsuccessful
  1.  K ^TMP("ABSP",$J,"ABSPOSD2",$J,"DELSUB")
  1.  S ^TMP("ABSP",$J,"ABSPOSD2",$J,"DELSUB")=$$ERRHDR
  1.  D ZWRITE^ABSPOS("IEN","FDA","MSG")
  1.  G DE3:$$IMPOSS^ABSPOSUE("FM","TR1",,,"DELSUB",$T(+0))
  1.  Q
  1.  ;
  1. DELREC(DLIEN) ;delete record - no valid information
  1.  ;
  1.  N FDA,MSG
  1.  ;
  1.  S FDA(9002313.473,DLIEN_",",.01)="@"
  1. DEL3 D FILE^DIE("E","FDA","MSG")     ;delete the record
  1.  Q:'$D(MSG)   ;successful deletion
  1.  I $D(MSG) D LOG^ABSPOSL2("DEL3^ABSPOSD2",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
  1.  ;
  1.  ; delete unsuccessful
  1.  K ^TMP("ABSP",$J,"ABSPOSD2",$J,"DELREC")
  1.  S ^TMP("ABSP",$J,"ABSPOSD2",$J,"DELREC")=$$ERRHDR
  1.  D ZWRITE^ABSPOS("IEN","FDA","MSG")
  1.  G DEL3:$$IMPOSS^ABSPOSUE("FM","TR1",,,"DELREC",$T(+0))
  1.  Q
  1.  ;
  1. NEWSUB(DURIEN) ;EP FROM ABSPOSIH
  1.  ; establish blank lines for new DUR override entries
  1.  ; on NEW POS claims (from page 20 on ABSP DATA INPUT)
  1.  ;(block ABSP INPUT 5.1 DUR INPUT)
  1.  ;
  1.  N REC,LASTREC,CNT,FDA,RECNUM,REP,SAVNUM,ZERR  ; /IHS/OIT/RAM ; 12 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
  1.  S (CNT,LASTREC,SAVNUM,REC)=0
  1.  ;
  1.  F  S REC=$O(^ABSP(9002313.473,DURIEN,1,REC)) Q:'+REC  D
  1.  . S SAVNUM=$P($G(^ABSP(9002313.473,DURIEN,1,REC,0)),"^")
  1.  . S:SAVNUM>LASTREC LASTREC=SAVNUM
  1.  . S CNT=CNT+1
  1.  ;
  1.  S:LASTREC>91 LASTREC=55  ;rec # lmt 99- 55 is random
  1.  S ENDCNT=9-CNT   ;tie to the rep num on screen blk
  1.  ;
  1.  F REP=1:1:ENDCNT  D
  1.  . S RECNUM=LASTREC+REP
  1.  . N FDA,IEN,ZERR  ; /IHS/OIT/RAM ; 12 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
  1.  . S FDA(9002313.4731,"+1,"_DURIEN_",",.01)=RECNUM
  1.  . D UPDATE^DIE("E","FDA","IEN","ZERR") ; /IHS/OIT/RAM ; 12 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
  1.  . I $D(ZERR) D LOG^ABSPOSL2("NEWSUB^ABSPOSD2",.ZERR) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
  1.  ;
  1.  ;
  1.  Q
  1.  ;
  1. FLOCK() L +^ABSP(9002313.473):300 Q $T
  1. FUNLOCK L -^ABSP(9002313.473) Q
  1. ERRHDR() Q "ERROR AT $H="_$H_" FOR $J="_$J