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

ABSPOSI.m

Go to the documentation of this file. 
  1. ABSPOSI ; IHS/FCS/DRS - Data entry w/ScreenMan ;   [ 09/12/2002  10:10 AM ]
  1.  ;;1.0;PHARMACY POINT OF SALE;**3,6,23,48**;JUN 21, 2001;Build 38
  1.  ; This calls ScreenMan for an entry in file 9002313.51
  1.  ;------------------------------------------------
  1.  ;IHS/SD/lwj  7/17/03  patch 6
  1.  ; Cache does NOT react the same as MSM when you are in screen man
  1.  ; and you call FULL^VALM1 prior to updating the record.  Changed
  1.  ; the sequence of when FULL^VALM1 is called in the ALL1 subroutine.
  1.  ; Also added another temp global to track the DUR overrides - if
  1.  ; the claim is not filed, we need to delete the empty records
  1.  ; so that the claim is not contaminated.
  1.  ;---------------------------------------------------------------
  1.  ;
  1. ALL ; This entry point does data entry and submits the claims, both.
  1.  ; This is what we'll call from the ListManager menu.
  1.  DO FULL^VALM1 ; List manager had set scroll regions
  1.  I $$OLDSTYLE G ^ABSPOSIV
  1. ALL1 ;EP - ABSPOSIV branches back here if user decides he wants Screenman
  1.  N INPUTIEN S INPUTIEN=$$NEW
  1.  ;D TERM^VALM0 ; sets terminal characteristics ; not in LM docum'n
  1.  I INPUTIEN D
  1.  . ;IHS/SD/lwj 07/17/03 nxt line moved two down - seq off for Cache
  1.  . ;D FULL^VALM1 ; full screen - we might do I/O
  1.  . D FILE^ABSPOSIZ(INPUTIEN) ; send them to POS or to paper
  1.  . ;IHS/SD/lwj 07/17/03 moved screen refresh to next line
  1.  . D FULL^VALM1 ; full screen - we might do I/O
  1.  . N NODISPLY S NODISPLY=1 D UPD^ABSPOS6A ; so your new claims show up
  1.  . N % W ! R %:1
  1.  E  D
  1.  . ;IHS/SD/lwj 7/17/03 patch 6 kill DUR overrides that are empty
  1.  . D NOCLM^ABSPOSIH
  1.  . ;end changes
  1.  . ;
  1.  . ;IHS/SD/RLT - 06/21/07 - 10/18/07 - Patch 23
  1.  . ; kill empty DIAGNOSIS CODE
  1.  . D NOCLM^ABSPOSII
  1.  . ;
  1.  . W "Because of <PF1> Q,",!
  1.  . W "These charges and claims are NOT filed and processed.",!
  1.  . W ! R %:3
  1.  W !
  1.  S VALMBCK="R" ; tell List Manager to Refresh
  1.  ;
  1.  ;IHS/SD/lwj 7/17/03 patch 6 - kill the temp global for the DUR over
  1.  K ^TMP("ABSPOSIH",$J)
  1.  ;
  1.  ;IHS/SD/RLT - 06/21/07 - 10/18/07 - Patch 23
  1.  ; kill temp global for DIAGNOSIS CODE
  1.  K ^TMP("ABSPOSII",$J)
  1.  ;
  1.  Q
  1.  ;
  1.  ; Usually, for a new input session, $$NEW^ABSPOSI 
  1.  ;   It returns the IEN of the session
  1.  ;
  1.  ; D ^ABSPOSI -> TEST^ABSPOSI  for testing and development
  1.  ;
  1.  ; If you need to edit an existing session, $$MYSCREEN^ABSPOSI(IEN)
  1.  ; That's probably not going to be used, but it's here if you need it.
  1.  ;
  1.  Q
  1. NEW() ;EP - from ABSPOSI
  1.  Q $$MYSCREEN(-1)
  1.  Q
  1. MYSCREEN(DA)       ; returns IEN of input if <PF1>E (or the equivalent) was used
  1.  ; if the user quits out (<PF1>Q or the equivalent), returns 0^IEN
  1.  N DDSFILE,DR,DDSPAGE,DDSPARM
  1.  N DDSCHANG,DDSSAVE,DIMSG,DTOUT
  1.  ;
  1.  ;IHS/SD/lwj 7/17/03 patch 6 - kill the temp global for the DUR over
  1.  K ^TMP("ABSPOSIH",$J)
  1.  ;
  1.  ;IHS/SD/RLT - 06/21/07 - 10/18/07 - Patch 23
  1.  ; kill temp global for DIAGNOSIS CODE
  1.  K ^TMP("ABSPOSII",$J)
  1.  ;
  1.  S DDSFILE=9002313.51 ; PEC/MIS INPUT file
  1.  S DR="[ABSP INPUT 1]"
  1.  I DA'>0 D
  1.  . S DA=$$NEWREC(,,2)
  1.  . D INIT(DA)
  1.  S DDSPARM="CS"
  1.  D ^DDS
  1.  Q:'$Q
  1.  I $G(DDSSAVE) Q DA
  1.  E  Q 0_U_DA
  1. TEST ;
  1.  W "NEW^ABSPOSI returns ",$$NEW^ABSPOSI
  1.  W "Outputs:",!
  1.  D ZWRITE^ABSPOS("DDSCHANG","DDSSAVE","DIMSG","DTOUT")
  1.  D GL
  1.  Q:$Q DA Q
  1. ISEMPTY(DA)        ; true if PRESCRIPTIONS multiple count >0, false if not
  1.  Q $P($G(^ABSP(9002313.51,DA,2,0)),U,4)>0
  1. FN() Q 9002313.51
  1. FNPRESC()          Q 9002313.512
  1. FNINS() Q 9002313.522
  1. NEWREC(NMULT,NINS,ORIGIN) ;EP - from ABSPOSIV - a new PEC/MIS INPUT record
  1.  ; NMULT = how many multiples to initialize (opt, defaults to 9)
  1.  ; NINS = how many insurance lines to init for each one (opt, def to 5)
  1.  ; ORIGIN = pointer to 9002313.516
  1.  N FDA,IEN,MSG,FN,NEW S FN=$$FN,NEW="+999999,"
  1.  N FNPRESC,FNINS S FNPRESC=$$FNPRESC,FNINS=$$FNINS
  1.  S FDA(FN,NEW,.01)="NOW"
  1.  S FDA(FN,NEW,.03)=$P(^ABSP(9002313.516,ORIGIN,0),U)
  1.  N I F I=1000:1000:1000*$S($D(NMULT):NMULT,1:9) D
  1.  . N X S X="+"_I_","_NEW
  1.  . S FDA(FNPRESC,X,.01)=I/1000
  1.  . N J F J=1:1:$S($D(NINS):NINS,1:5) D
  1.  . . S FDA(FNINS,"+"_(I+J)_","_X,.01)=J
  1.  . . ; ex:          +3002,+3000,+999999, for 2nd ins in 3rd presc
  1.  N STOP F  D  Q:STOP
  1.  . D UPDATE^DIE("E","FDA","IEN","MSG")
  1.  . I $D(MSG) D LOG^ABSPOSL2("NEWREC^ABSPOSI",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
  1.  . I '$D(MSG),$G(IEN(999999)) S STOP=1 Q
  1.  . D ZWRITE^ABSPOS("MSG","IEN")
  1.  . S STOP='$$IMPOSS^ABSPOSUE("FM","TRI","UPDATE^DIE failed",,"NEWREC",$T(+0))
  1.  Q IEN(999999)
  1. INIT(IEN) ;EP - from ABSPOSIV - initialize record IEN
  1.  N FDA,MSG,FN S FN=$$FN,IEN=IEN_","
  1.  S FDA(FN,IEN,.02)=DUZ ; USER
  1.  D
  1.  . N ARR,I,Y
  1.  . D GET515(DUZ,.ARR) ; get this user's settings, apply defaults
  1.  . S Y=$G(ARR(1)) ; we're interested in the ASK ones in the 1 subscript
  1.  . F I=1:1:4 I $P(Y,U,I)="" S $P(Y,U,I)=0 ; defaults for default
  1.  . F I=1:1:4 S FDA(FN,IEN,I/100+1)=$P(Y,U,I) ; ASK INS, etc.
  1.  . S Y=$G(ARR(100)) ; and in the 100 subscript,
  1.  . ; piece 1 - should we default the NDC # - the default default is YES
  1.  . ; defaults for the default
  1.  . F I=1:1:1 I $P(Y,U,I)="" S $P(Y,U,I)=$S(I=1:1,1:0)
  1.  . F I=1:1:1 S FDA(FN,IEN,I/100+100)=$P(Y,U,I)
  1.  N STOP F  D  Q:STOP
  1.  . D FILE^DIE("","FDA","MSG")
  1.  . I $D(MSG) D LOG^ABSPOSL2("INIT^ABSPOSI",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
  1.  . I '$D(MSG) S STOP=1 Q
  1.  . D ZWRITE^ABSPOS("MSG")
  1.  . S STOP='$$IMPOSS^ABSPOSUE("FM","TRI","FILE^DIE failed",,"INIT",$T(+0))
  1.  Q:$Q '$D(MSG) Q  ;='0=1 if success, ='nonzero=0 if failure
  1. DELALL ; delete all records ; good for testing
  1.  N FN S FN=$$FN I FN'=9002313.51 D  Q  ; must be that file
  1.  . D IMPOSS^ABSPOSUE("P","TI",,,"DELALL",$T(+0))
  1.  W !,"Deleting all records from file ",FN
  1.  N IEN F  S IEN=$O(^ABSP(FN,0)) Q:'IEN  Q:'$$DELETE(IEN)  W "."
  1.  W ! D GL
  1.  Q
  1. GL ; quickie global list good for testing
  1.  N FN S FN=$$FN
  1.  N X M X=^ABSP(FN)
  1.  D ZWRITE^ABSPOS("X")
  1.  Q
  1. DELETE(IEN)        ; delete record IEN
  1.  N FDA,MSG,FN S FN=$$FN,IEN=IEN_","
  1.  S FDA(FN,IEN,.01)="@"
  1.  D FILE^DIE("E","FDA","MSG")
  1.  I $D(MSG) D LOG^ABSPOSL2("DELETE^ABSPOSI",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
  1.  I $D(MSG) D ZWRITE^ABSPOS("MSG") Q 0 ; /IHS/OIT/RAM ; CONSOLIDATE TWO LINES INTO ONE FOR CLARITY. 
  1.  Q 1
  1. GENINSTR ; general instructions, in the FORM-level pre-action for Block 2C
  1.  N AR
  1.  S AR(1)="Use   <PF1> E   to SUBMIT the claims"
  1.  S AR(1)=AR(1)_",    <PF1> Q to QUIT and cancel"
  1.  ;S AR(2)="Use   <PF1> Q   to QUIT without submitting claims."
  1.  ;S AR(3)="Use     ??     to get extra help on a question."
  1.  D HLP^DDSUTL(.AR)
  1.  Q
  1. OLDSTYLE()         ; return true if DUZ wants old style input
  1.  ; if this user has a specific setting, go with it
  1.  N X D GET515(DUZ,.X)
  1.  Q $P($G(X(0)),U,3)
  1. GET515(USER,DEST) ;EP - from ABSPOSIV ; call as GET515(USER,.DESTINATION)
  1.  ; where .DESTINATION is undefined coming in.
  1.  ; set DEST(*) = copy of the .515 in effect,
  1.  ; with defaults overlaid as needed
  1.  I $D(DEST) D  Q
  1.  . D IMPOSS^ABSPOSUE("P","TI",,,"GET515",$T(+0))
  1.  D GET515A(USER,.DEST)
  1.  I $P($G(DEST(0)),U,2) D  ; if this user inherits from another, 
  1.  . N ARR
  1.  . D GET515A(USER,.ARR) ; then get that user's settings
  1.  . D GET515B(.DEST,.ARR) ; fill in any that need defaults
  1.  D
  1.  . N ARR
  1.  . D GET515A(1,.ARR) ; likewise, inherit from user #1
  1.  . D GET515B(.DEST,.ARR)
  1.  Q
  1. GET515A(USER,DEST) ; grab copy of the record for this user
  1.  N IEN S IEN=$O(^ABSP(9002313.515,"B",USER,0)) Q:'IEN
  1.  M DEST=^ABSP(9002313.515,IEN) ; DEST(0), DEST(1), etc. are set now
  1.  Q
  1. GET515B(A,B)       ; fill in defaults in A as needed, from B
  1.  N X,Y,I,S S S=""
  1.  F  S S=$O(B(S)) Q:S=""  D
  1.  . S X=B(S) F I=1:1:$L(X,U) S Y=$P(X,U,I) I Y]"" D
  1.  . . I $P($G(A(S)),U,I)="" S $P(A(S),U,I)=Y ; not def, so fill default
  1.  Q