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