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

ABSPOSI8.m

Go to the documentation of this file. 
  1. ABSPOSI8 ; IHS/FCS/DRS - insurance selection - page 8 ;   [ 11/06/2002  1:26 PM ]
  1.  ;;1.0;PHARMACY POINT OF SALE;**3**;JUN 21, 2001;Build 38
  1.  Q
  1. FN() Q 9002313.522
  1. INIT ;EP - from ABSPOSI7
  1.  ;This initializes the page 8 data.
  1.  ; It's called as the entry action for page 8.
  1.  ;
  1.  ; We have DIE, DA(1) and DA, which point us into
  1.  ;    ^ABSP(9002313.51,DA(1),2,DA,*)
  1.  ; We want to initialize the insurance data in
  1.  ;    ^ABSP(9002313.51,DA(1),2,DA,"I",*)
  1.  ;
  1.  ; All the line items are already created, before we entered the form,
  1.  ; and there's a fixed number of them.  Unpleasant, but true. 
  1.  ; We tried various kludgey ways to call UPDATE^DIE and create a
  1.  ; variable-length list at the time the page was loaded, but it
  1.  ; had various problems and we gave up.  Hopefully, there are enough
  1.  ; line items to hold everything that's needed.   If there aren't,
  1.  ; let's try to always make SELF PAY the last one, always leaving
  1.  ; room for SELF PAY.
  1.  ;
  1.  ; We always refresh with newest stuff from a call to ABSPOS25.
  1.  ; But if we had an existing order, we will impose that order on
  1.  ; the ABSPOS25 results.
  1.  ;
  1.  ;
  1.  ; How many entries are there?  We can look at the global because
  1.  ; the size is, regrettably, fixed.
  1.  N NINS S NINS=$P(^ABSP(9002313.51,DA(1),2,DA,"I",0),U,4)
  1.  ;
  1.  ; What is the current order? (For efficient assignment later).
  1.  N ORDER D
  1.  . N I F I=1,2,3 D
  1.  . . N X S X=$$GET^DDSVAL(DIE,.DA,"6.0"_I)
  1.  . . I X]"" S ORDER(X)=I
  1.  ; First, call ABSPOS25, giving ARRAY
  1. 1 N ARRAY D AVAIL() ; what insurance choices are available, per A/R?
  1.  ; Fill in defaults for any 6.01,7.01,...,6.03,7.03 that are empty
  1.  D  ; fill in any missing orders
  1.  . N I S I=0 ; source pointer
  1.  . N J,K S K=0 F J=1:1:3 I $$GET^DDSVAL(DIE,.DA,J/100+6)=""  S K=J Q
  1.  . I 'K Q  ; all three slots already in use
  1.  . ; J = first slot available
  1.  . N STOP S STOP=0
  1.  . F  D  Q:STOP
  1.  . . S I=I+1 I I>ARRAY(0) S STOP=1 Q  ; exhausted the ARRAY()
  1.  . . N PINS S PINS=$P(ARRAY(I),U,2) ; is this entry already in top 3?
  1.  . . I $D(ORDER(PINS)) Q  ; yes, already in top 3
  1.  . . D PUT^DDSVAL(DIE,.DA,J/100+6,PINS) ; not in top 3 yet, assign it
  1.  . . D PUT^DDSVAL(DIE,.DA,J/100+7,$P(ARRAY(I),U),,"I") ; store corr. INSIEN
  1.  . . S ORDER(PINS)=J
  1.  . . I J=3 S STOP=1 Q
  1.  . . S J=J+1 ; advance to next 
  1. 2 ; Do not delete old entries - we're not allowed to delete existing
  1.  ; entries with PUT^DDSVAL, and we surely shouldn't KILL them off.
  1.  I 0 D
  1.  . N X S X="" N S S S="" F  S S=$O(ORDER(S)) Q:S=""  D
  1.  . . S X=X_"ORDER("_S_")="_ORDER(S)_"; "
  1.  . D MSGWAIT^ABSPOSI1(X)
  1. 3 D STOREARR() ; set up the database
  1.  Q
  1. MSGWAIT(X)         D MSGWAIT^ABSPOSI1(X) Q
  1. AVAIL() ;Use ABSPOS25 to get the very latest insurance information.
  1.  ; 
  1.  K ARRAY ; fills ARRAY(*)
  1.  D  ; set up parameters and make the call to ABSPOS25
  1.  . N FRESH S FRESH=1 ; without regard to previous visits
  1.  . N ABSBRXI S ABSBRXI=$$GET^DDSVAL(DIE,.DA,1.01)
  1.  . N ABSBRXR S ABSBRXR=$$GET^DDSVAL(DIE,.DA,1.02)
  1.  . N ABSBPATI S ABSBPATI=$$GET^DDSVAL(DIE,.DA,1.04)
  1.  . N ABSBVISI S ABSBVISI=$$GET^DDSVAL(DIE,.DA,1.06)
  1.  . D INSURER^ABSPOS25(.ARRAY,FRESH,NINS)
  1.  ; ARRAY(0)=count and then some other stuff
  1.  ; ARRAY(n)=insurer IEN ^ PINS
  1.  QUIT
  1. STOREARR() ; setup entries in database and on form, based on ARRAY(*)
  1.  N ENTRY F ENTRY=1:1:$P(ARRAY(0),U) D SETUP1
  1.  Q
  1. SETUP1 ; for ARRAY(ENTRY)
  1.  N INSIEN,PINS S INSIEN=$P(ARRAY(ENTRY),U),PINS=$P(ARRAY(ENTRY),U,2)
  1.  N RECNUM S RECNUM=$$FIND(PINS) ; find the PINS record
  1.  I 'RECNUM D
  1.  . S RECNUM=$$NEW ; if not found, assign a new one and set it up
  1.  E  D STORE(RECNUM,PINS,INSIEN)
  1.  Q
  1. FIND(PINS) ; given DA(1),DA - does it exist?
  1.  ; return record number, or false if not found
  1.  N RET,STOP,FN S (RET,STOP)=0,FN=$$FN
  1.  S DA(2)=DA(1),DA(1)=DA
  1.  N RECNUM F RECNUM=1:1:NINS D  Q:STOP
  1.  . N ERR
  1.  . S DA=RECNUM
  1.  . I $$GET^DDSVAL(FN,.DA,.04)=PINS S (RET,STOP)=DA ; found
  1.  S DA=DA(1),DA(1)=DA(2) K DA(2) ; restore state of DA
  1.  Q RET
  1. NEW() ; given DA(1),DA,PINS,INSIEN - init a new record
  1.  N RECNUM S RECNUM=$$FIND("") ; first one with a null PINS
  1.  I RECNUM="" Q 0 ; none available
  1.  D STORE(RECNUM,PINS,INSIEN)
  1.  Q:$Q RECNUM Q
  1. STORE(RECNUM,PINS,INSURER)   ;
  1.  S DA(2)=DA(1),DA(1)=DA,DA=RECNUM ; set up DA for this level
  1.  N FN S FN=$$FN
  1.  D PUT^DDSVAL(FN,.DA,.02,$G(ORDER(PINS))) ;
  1.  D PUT^DDSVAL(FN,.DA,.03,INSURER,,"I")
  1.  D PUT^DDSVAL(FN,.DA,.04,PINS)
  1.  S DA=DA(1),DA(1)=DA(2) K DA(2) ; restore state of DA
  1.  Q:$Q RECNUM Q
  1. ERASEALL ;EP - from ABSPOSI1
  1.  ;erase all data in the "I" multiple
  1.  ; given DA(1)=entry number in 9002313.51
  1.  ;       DA = line number in LINE ITEMS multiple
  1.  ; Refer to the global only for figuring how many of these there are
  1.  ; This is needed because if someone DELETEs a prescription line,
  1.  ; we have to erase all the data associated with that line.  This is
  1.  ; called from ABSPOSI1, where the DELETE is handled.
  1.  I $O(DA(1)) D IMPOSS^ABSPOSUE("P","TI","At wrong data level in form",,"ERASEALL",$T(+0)) Q  ; make sure you're really at this level DA(1) not DA(2)
  1.  S DA(2)=DA(1),DA(1)=DA,DA=0
  1.  N FN S FN=$$FN
  1.  F  S DA=$O(^ABSP(9002313.51,DA(2),2,DA(1),"I",DA)) Q:'DA  D
  1.  . Q:'$$GET^DDSVAL(FN,.DA,.03)  ; no insurer on this line
  1.  . N F F F=.02,.03,.04,1.01 D
  1.  . . D PUT^DDSVAL(FN,.DA,F,"",,"I")
  1.  S DA=DA(1),DA(1)=DA(2) K DA(2) ; restore the DA array
  1.  Q
  1. POST02 ; POST ACTION ON CHANGE for ORDER, field .02
  1.  ; DA=which insurer line  DA(1)=which prescription line  DA(2)=IEN
  1.  ; X=new internal value, DDSOLD = previous internal value
  1.  ; This has side effects:
  1.  ;     Example:  assign order #2 to some item
  1.  N THISDA S THISDA=DA
  1.  F DA=1:1 Q:'$D(^ABSP(9002313.51,DA(2),2,DA(1),"I",DA))  D
  1.  . Q:DA=THISDA  ; but skip the one you're changing right now
  1.  . ; For each field, get its current order
  1.  . N THISORD S THISORD=$$GET^DDSVAL(DIE,.DA,.02,,"I")
  1.  . ;
  1.  . ; DDSOLD=""   example:  pick one unassigned and make it #2
  1.  . ; then #3 disappears and old #2 becomes #3
  1.  . I DDSOLD="" D
  1.  . . I THISORD="" ;do nothing, it remains blank
  1.  . . E  I THISORD=3 D
  1.  . . . D PUT^DDSVAL(DIE,.DA,.02,"",,"I")
  1.  . . E  I THISORD'<X D
  1.  . . . D PUT^DDSVAL(DIE,.DA,.02,THISORD+1,,"I")
  1.  . . . D SET70X(THISORD+1) ; ABSP*1.0T7*8
  1.  . ;
  1.  . ; X>DDSOLD  example:  change 2nd to be 3rd ; X=3,DDSOLD=2
  1.  . E  I X>DDSOLD D  ; so 3rd moves up to 2nd (1st unaffected)
  1.  . . I THISORD="" Q  ; unassigned ones unaffected
  1.  . . I THISORD>DDSOLD,THISORD'>X D
  1.  . . . D PUT^DDSVAL(DIE,.DA,.02,THISORD-1,,"I")
  1.  . . . D SET70X(THISORD-1) ; ABSP*1.0T7*8
  1.  . ;
  1.  . ; X<DDSOLD  example:  change 2nd to be 1st ; X=1,DDSOLD=2
  1.  . E  I X<DDSOLD D  ; so 1st drops to 2nd and 3rd is unaffected
  1.  . . I THISORD="" Q  ; unassigned ones unaffected
  1.  . . I THISORD<DDSOLD,THISORD'<X D
  1.  . . . D PUT^DDSVAL(DIE,.DA,.02,THISORD+1,,"I")
  1.  . . . D SET70X(THISORD+1) ; ABSP*1.0T7*8
  1.  S DA=THISDA ; restore original value!
  1.  Q
  1. SET70X(ORDER) ; update 9002313.512 fields 7.01, 7.02, 7.03 ; ABSP*1.0T7*8
  1.  ; ORDER = 1, 2, 3
  1.  N INS,SAVEDA,FN
  1.  S INS=$$GET^DDSVAL(DIE,.DA,.03,"I") ; insurer IEN
  1.  S FN=9002313.512 ; the LINE ITEMS multiple
  1.  M SAVEDA=DA K DA S DA=SAVEDA(1),DA(1)=SAVEDA(2)
  1.  D PUT^DDSVAL(FN,.DA,"7.0"_ORDER,INS,,"I")
  1.  K DA M DA=SAVEDA ; restore original DA
  1.  Q