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

ABSPOSIY.m

Go to the documentation of this file. 
  1. ABSPOSIY ; IHS/FCS/DRS - Filing with .51,.59 ;    [ 08/30/2002  10:26 AM ]
  1.  ;;1.0;PHARMACY POINT OF SALE;**3,34,48**;JUN 21, 2001;Build 38
  1.  ; continuation of ABSPOSIZ
  1.  ;----------------------------------------------------------------
  1.  ;IHS/SD/lwj 8/30/02  NCPDP 5.1 changes
  1.  ; With 5.1 came a new way to handle and process the prior authorization
  1.  ; code.  In 3.2, this was very horriably managed in field 416 - it
  1.  ; contained both the type of authorization indicator and the 
  1.  ; authorization number.  In 5.1, field 416 is no longer supported and
  1.  ; the type and number were split into their own fields (fld 461 is 
  1.  ; the type and fld 462 is now the number).  To incorporate this new
  1.  ; change, the screen was altered to prompt for both fields, and 
  1.  ; for now, we will simply concatenate the values to create field 416
  1.  ; for those claims that still use the 3.2 format.
  1.  ; Changes were made to this program to capture the new prior auth
  1.  ; type code in the transaction file.
  1.  ;------------------------------------------------------------------
  1.  Q
  1. IEN59() ;EP - given INPUT(), what should we use for an IEN in file 9002313.59?
  1.  ; It's always a decimal, canonic number.
  1.  ;
  1.  ;For prescriptions and associated postage:
  1.  ;
  1.  ;  Let RXI = prescription ien, pointer to ^PSRX(RXI)
  1.  ;  Let RXR = refill multiple, pointer to ^PSRX(RXI,1,RXR)
  1.  ;      RXR = 0 if this is the first fill
  1.  ;  Let D = 1 if this is a charge for the prescription,
  1.  ;      D = 2 if this is a charge for the postage
  1.  ;  Then $$IEN59 = RXI_"."_$J(RXR,4)_D
  1.  ;  Example:  341641.00001   first fill of #341641
  1.  ;            341641.00002   postage for it
  1.  ;
  1.  ;For non-prescription items:
  1.  ;  Let VSTDFN = visit ien, pointer to ^AUPNVSIT(VSTDFN)
  1.  ;  Let CPTIEN = charge file IEN, pointer to ^ABSCPT(9002300,CPTIEN)
  1.  ;  Then $$IEN59 = VSTDFN_"."_$J(CPTIEN,6)_"3"
  1.  ;
  1.  ;  Example:  if VSTDFN = 1216873 and CPTIEN = 10322,
  1.  ;            1216873.0103223
  1.  ;
  1.  N RXI,RET
  1.  S RXI=$P(INPUT(1),U)
  1.  I RXI D
  1.  . S RXR=$P(INPUT(1),U,2)
  1.  . I RXR>9000 D
  1.  . . D IMPOSS^ABSPOSUE("DB","TI","Refill number near overflow point","RXI="_RXI,"IEN59",$T(+0))
  1.  . ; you can raise the limit and be thinking of how to get around it
  1.  . S RET=RXI_"."_$TR($J(RXR,4)," ","0")
  1.  . S RET=RET_$S($P(INPUT(0),U,3)?1"POSTAGE".E:2,1:1)
  1.  E  D
  1.  . N VIS,CPT S VIS=$P(INPUT(1),U,6),CPT=$P(INPUT(1),U,8)
  1.  . I 'VIS D  ; visit IEN, must not be zero
  1.  . . D IMPOSS^ABSPOSUE("P","TI","Visit IEN missing; should have been detected by now",,"IEN59",$T(+0))
  1.  . . S VIS="MISSING"
  1.  . I 'CPT D  ; CPT IEN, must not be zero
  1.  . . D IMPOSS^ABSPOSUE("P","TI","CPT IEN missing; should have been detected by now",,"IEN59",$T(+0))
  1.  . . S CPT="MISSING"
  1.  . S RET=VIS_"."_$TR($J(CPT,6)," ","0")_3
  1.  Q RET
  1.  ;SETUP59(N,ORIGIN) ;EP - from ABSPOSIZ -  given the INPUT array
  1. SETUP59(N,ORIGIN,ABSPUSR) ;EP - from ABSPOSIZ -  given the INPUT array - IHS/OIT/SCR 082709 patch 34
  1.  ; You don't have to set null fields, so long as you have called
  1.  ; CLEAR, or if this is a NEW entry.
  1.  N FLAGS,FDA,MSG,FN,REC,X,I S FN=9002313.59,REC=N_","
  1.  N TYPE S TYPE=$E(N,$L(N))
  1.  S FDA(FN,REC,.13)=TYPE
  1.  ; TYPE = 1 for prescription, = 2 for mailing prescription,
  1.  ;      = 3 for non-prescription items
  1.  ; FDA(FN,REC,.01) = $P(INPUT(0),U,1) already stored in = field .01
  1.  S FDA(FN,REC,.14)=ORIGIN
  1.  S FDA(FN,REC,6)=ABSPUSR  ;IHS/OIT/SCR 082709 patch 34
  1.  S FDA(FN,REC,1)=0 ; STATUS - waiting to start
  1.  ; Field 1.06 - copied from field 701, below
  1.  S FDA(FN,REC,1.08)=1 ; PINS piece
  1.  I TYPE=1!(TYPE=2) S FDA(FN,REC,1.11)=$P(INPUT(1),U) ; RXI
  1.  ;
  1.  ;IHS/SD/lwj 8/30/02 NCPDP 5.1 changes
  1.  ; the prior authorization code is now two fields - type and number
  1.  ; begin changes to capture both values
  1.  ;
  1.  I $D(INPUT(2)),$P(INPUT(2),U,2)]"" D
  1.  . S FDA(FN,REC,1.09)=$P(INPUT(2),U)    ; prior authorization number 
  1.  . S FDA(FN,REC,1.15)=$P(INPUT(2),U,2)  ; prior auth type code 
  1.  ;
  1.  ;IHS/SD/lwj 8/30/02 end NCPDP 5.1 prior authorization changes
  1.  ;
  1.  S FDA(FN,REC,5)=$P(INPUT(1),U,4) ; Patient
  1.  S FDA(FN,REC,7)=$$NOW ; LAST UPDATE
  1.  S FDA(FN,REC,9)=$P(INPUT(1),U,2) ; RXR - refill index
  1.  I TYPE=1 S FDA(FN,REC,10)=$P(INPUT(0),U,3) ; NDC
  1.  I TYPE=1!(TYPE=2) S FDA(FN,REC,12)=$P(INPUT(1),U,6) ; Visit
  1.  S FDA(FN,REC,13)=DUZ ; USER
  1.  S FDA(FN,REC,15)=FDA(FN,REC,7) ; START TIME
  1.  ;IHS/OIT/SCR 12/09/08 patch 28 SAVE NEW PRICE FIELD 'incentive amount' too
  1.  ;F I=1:1:6 S X=$P($G(INPUT(5)),U,I) I X]"" S FDA(FN,REC,500+I)=X
  1.  F I=1:1:7 S X=$P($G(INPUT(5)),U,I) I X]"" S FDA(FN,REC,500+I)=X
  1.  I $G(INPUT(6))]""!($G(INPUT(7))]"") D
  1.  . F I=1:1:3 D
  1.  . . I $P(INPUT(6),U,I)]"" S FDA(FN,REC,600+I)=$P($G(INPUT(6)),U,I)
  1.  . . I $P(INPUT(7),U,I)]"" S FDA(FN,REC,700+I)=$P($G(INPUT(7)),U,I)
  1.  I $D(FDA(FN,REC,701)) D
  1.  . S FDA(FN,REC,1.06)=FDA(FN,REC,701) ; INSURER
  1.  ; 500's, 600's, 700's done above
  1.  D FILE^DIE("","FDA","MSG") ; NO "E" FLAG - DATA IS IN INTERNAL FORMAT!
  1.  I $D(MSG) D LOG^ABSPOSL2("SETUP59^ABSPOSIY",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
  1.  ;I $D(MSG) ZW MSG
  1.  Q $S($D(MSG):0,1:1)
  1. ACTIVEWT(IEN59,IEN51,IEN512) ;EP - from ABSPOSIZ
  1.  ; Return 0 = forget about it, don't wait, just skip this one
  1.  ;        1 = yes, wait and check again in several seconds from now
  1.  ;        
  1.  N PROMPT
  1.  ; An opportunity to wait for the active prescription to finish
  1.  ; processing.  Return 1 if you do want to wait; 0 if you do not. 
  1.  I '$G(ECHO) Q 1  ; not interactive, you can't ask - assume YES, wait
  1.  W ?5,"There is currently an active transaction for this item"
  1.  ;The new IEN59 should decisively say if it's the same date.
  1.  ;N X,Y S X=$P(^ABSPT(IEN59,1),U)
  1.  ;S Y=$P(^ABSP(9002313.51,IEN51,2,IEN512,0),U,8)
  1.  ;I X'=Y W !?5,"though for a different fill date"
  1.  W ".",!
  1.  W ?5,"So this item will be skipped.",! H 1 ; 03/22/2001
  1.  Q 0 ; 03/22/2001
  1. ACWTA S PROMPT="Do you want to wait for the active transaction to finish"
  1.  S Y=$$YESNO^ABSPOSU3(PROMPT,"YES",1) W !
  1.  I Y=1 Q 1
  1.  S PROMPT="Do you want to forget about this one"
  1.  S Y=$$YESNO^ABSPOSU3(PROMPT,"NO",1) W !
  1.  I Y=1 Q 0
  1.  G ACWTA
  1. RXPREV(IEN,ENTRY)  ; has this item previously been through point of sale?
  1.  ; return false if not
  1.  ; return pointer to 9002313.57 if true
  1.  N RXI,RXR,VIS,CPT,INDEX,A,B
  1.  S RXI=$$RXI(IEN,ENTRY)
  1.  I RXI D
  1.  . S RXR=$$RXR(IEN,ENTRY)
  1.  . S INDEX=$S($$NDC(IEN,ENTRY)?1"POSTAGE".E:"POSTAGE",1:"RXIRXR")
  1.  . S A=RXI,B=RXR
  1.  E  D
  1.  . S VIS=$$VIS(IEN,ENTRY)
  1.  . S CPT=$$CPTIEN(IEN,ENTRY)
  1.  . S A=VIS,B=CPT,INDEX="OTHERS"
  1.  Q $O(^ABSPTL("NON-FILEMAN",INDEX,A,B,""),-1)
  1. RXPAID(IEN,ENTRY)  ;EP - from ABSPOSIZ 
  1.  ; return true if the prescription and fill has a "paid"
  1.  ; status as far as point of sale is concerned
  1.  ; A paper claim counts as a point of sale "paid" for this purpose
  1.  ; Return 1 = POS, paid
  1.  ; Return 2 = paper
  1.  N N57 S N57=$$RXPREV(IEN,ENTRY)
  1.  I 'N57 Q ""  ; no point of sale record of this
  1.  ; If it's a reversal, then our result depends on the reversal:
  1.  ;    Was the reversal accepted?   If so, then No, not paid.
  1.  ;    Was the reversal rejected?   Assume Paid, since we try to
  1.  ;         allow reversals only in the case of a paid original.
  1.  I $$ISREVERS^ABSPOS57(N57) Q $S($$REVACC^ABSPOS57(N57):0,1:1)
  1.  ; Not a reversal:
  1.  N X S X=$$CATEG^ABSPOSUC(N57)
  1.  Q $S(X="E PAYABLE":1,X="PAPER":2,X="E DUPLICATE":3,1:0)
  1. RXI(IEN,ENTRY)     Q $P(^ABSP(9002313.51,IEN,2,ENTRY,1),U)
  1. RXR(IEN,ENTRY)     Q $P(^ABSP(9002313.51,IEN,2,ENTRY,1),U,2)
  1. VIS(IEN,ENTRY)     Q $P(^ABSP(9002313.51,IEN,2,ENTRY,1),U,6)
  1. NDC(IEN,ENTRY)     Q $P(^ABSP(9002313.51,IEN,2,ENTRY,0),U,3)
  1. CPTIEN(IEN,ENTRY)  Q $P(^ABSP(9002313.51,IEN,2,ENTRY,1),U,8)
  1. WANTREV()         ;EP - from ABSPOSIZ 
  1.  Q 0 ; TO BE IMPLEMENTED
  1. NOW() N %,%H,%I,X D NOW^%DTC Q %