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

ABSPOSD3.m

Go to the documentation of this file. 
  1. ABSPOSD3 ; IHS/SD/RLT - DIAGNOSIS CODE ;  [ 06/21/2007  11:10 AM ]
  1.  ;;1.0;PHARMACY POINT OF SALE;**23,48**;JUN 21, 2007;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.  ;
  1.  ; This routine is responsible for prompting and retaining
  1.  ; the repeating DIGANOSIS CODES in the CLINICAL segment.
  1.  ;
  1. EDIT(DIAGIEN) ;EP called from ABSPOSO1 (menu option)
  1.  ;**Don't believe this is needed for DIAGNOSIS CODE.
  1.  ;**Left code from DUR just in case.
  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=DIAGIEN
  1.  S DIE=9002313.491
  1.  S DR=1
  1.  D ^DIE
  1.  ;
  1.  Q
  1.  ;
  1. NEW() ;EP -  from ABSPOSII create new entry in 9002313.491
  1.  F  Q:$$FLOCK  Q:'$$IMPOSS^ABSPOSUE("L","RTI","interlock on new DIAG rec create",,"NEW",$T(+0))
  1.  ;
  1.  N FLAGS,FDA,IEN,MSG,FN,X,NEWREC
  1.  S FN=9002313.491
  1.  D NEW1^ABSPOSO2
  1.  D FUNLOCK
  1.  ;
  1.  Q NEWREC
  1.  ;
  1.  ;
  1. CHKDIAG(DIAGIEN) ;EP    from ABSPOSII
  1.  ;last step - delete if nothing entered
  1.  ;
  1.  N SUBR,FNDREC,CHKR
  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.491,DIAGIEN,1,SUBR)) Q:'+SUBR  D
  1.  . ;S CHKR=$TR($P($G(^ABSP(9002313.491,DIAGIEN,1,SUBR,0)),U,2,3),"^")
  1.  . S CHKR=$P($G(^ABSP(9002313.491,DIAGIEN,1,SUBR,0)),U,3)
  1.  . S:CHKR'="" FNDREC=0
  1.  . D:CHKR="" DELSUB(DIAGIEN,SUBR)
  1.  ;
  1.  I FNDREC D
  1.  . D DELREC(DIAGIEN)
  1.  . S DIAGIEN=""
  1.  ;
  1.  Q DIAGIEN
  1.  ;
  1. DELSUB(DLIEN,DLSUB) ; delete subrecord - no valid information
  1.  ;
  1.  N FDA,MSG
  1.  ;
  1.  S FDA(9002313.4911,DLSUB_","_DLIEN_",",.01)="@"
  1. DE3 D FILE^DIE("E","FDA","MSG")     ;delete the record
  1.  I $D(MSG) D LOG^ABSPOSL2("DE3^ABSPOSD3",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
  1.  Q:'$D(MSG)   ;successful deletion
  1.  ;
  1.  ; delete unsuccessful
  1.  K ^TMP("ABSP",$J,"ABSPOSD3",$J,"DELSUB")
  1.  S ^TMP("ABSP",$J,"ABSPOSD3",$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.491,DLIEN_",",.01)="@"
  1. DEL3 D FILE^DIE("E","FDA","MSG")     ;delete the record
  1.  I $D(MSG) D LOG^ABSPOSL2("DEL3^ABSPOSD3",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
  1.  Q:'$D(MSG)   ;successful deletion
  1.  ;
  1.  ; delete unsuccessful
  1.  K ^TMP("ABSP",$J,"ABSPOSD3",$J,"DELREC")
  1.  S ^TMP("ABSP",$J,"ABSPOSD3",$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(DIAGIEN) ;EP FROM ABSPOSII
  1.  ; establish blank lines for new DIAG override entries
  1.  ; on NEW POS claims (from page 20 on ABSP DATA INPUT)
  1.  ;(block ABSP INPUT 5.1 DIAG 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.491,DIAGIEN,1,REC)) Q:'+REC  D
  1.  . S SAVNUM=$P($G(^ABSP(9002313.491,DIAGIEN,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.4911,"+1,"_DIAGIEN_",",.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^ABSPOSD3",.ZERR) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
  1.  ;
  1.  Q
  1.  ;
  1. FLOCK() L +^ABSP(9002313.491):300 Q $T
  1. FUNLOCK L -^ABSP(9002313.491) Q
  1. ERRHDR() Q "ERROR AT $H="_$H_" FOR $J="_$J