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

ABSPOS57.m

Go to the documentation of this file. 
  1. ABSPOS57 ; IHS/FCS/DRS - 9002313.57 utils ;        [ 04/17/2002  11:36 AM ]
  1.  ;;1.0;PHARMACY POINT OF SALE;**1,12,35,36,44**;JUN 21, 2001;Build 38
  1.  Q
  1.  ; Numerous little $$'s are here ; each assumes IEN57 is defined
  1.  ; Originally copied from ABSPOSQ where it was for IEN57
  1.  ;
  1.  ;IHS/DSD/lwj 10/02  Two changes included in this routine, both
  1.  ; sent in by David Slauenwhite.  Changes were made and tested 
  1.  ; during the ILC interface work done at Siletz in October, 2001.
  1.  ;
  1.  ;-------------------------------------------------------
  1.  ;IHS/SD/lwj 6/16/05 patch 12 remove fld ids from 5.1 flds
  1.  ;-------------------------------------------------------
  1. PREVIOUS(N57) ;EP -
  1.  I '$D(N57) S N57=IEN57
  1.  N RXI,RXR S RXI=$P(^ABSPTL(N57,1),U,11)
  1.  S RXR=$P(^ABSPTL(N57,1),U)
  1.  I RXI=""!(RXR="") Q ""
  1.  Q $O(^ABSPTL("NON-FILEMAN","RXIRXR",RXI,RXR,N57),-1)
  1. LAST57(RXI,RXR) ;EP -
  1.  Q $O(^ABSPTL("NON-FILEMAN","RXIRXR",RXI,RXR,""),-1)
  1.  ;
  1. DRGDFN() ;EP -
  1.  Q $P(^PSRX($$RXI,0),U,6) ; Given IEN57, return DRGDFN
  1. DRGNAME() ; EP -
  1.  Q $P(^PSDRUG($$DRGDFN,0),U) ; Given IEN57, return DRGNAME
  1. RELDATE() ;EP -
  1.  N RXI,RXR S RXI=$$RXI,RXR=$$RXR Q:'RXI ""
  1.  I RXR Q $P($G(^PSRX(RXI,1,RXR,0)),U,18)
  1.  Q $P($G(^PSRX(RXI,2)),U,13)
  1. RXI() ;EP -
  1.  Q $P(^ABSPTL(IEN57,1),U,11) ; Given IEN57, return RXI
  1. RXR() ;EP -
  1.  Q $P(^ABSPTL(IEN57,1),U,1) ; Given IEN57, return RXR
  1. NDC() ;EP -
  1.  I $$TYPE=1 Q $P(^ABSPTL(IEN57,1),U,2)
  1.  I $$TYPE=2 Q "" ; not implemented
  1.  I $$TYPE=3 Q "" ; not implemented
  1.  D TYPEBAD("NDC")
  1.  Q ""
  1. QTY() ;EP -
  1.  Q $P(^ABSPTL(IEN57,5),U) ; Given IEN57, return quantity
  1. AMT() Q $P(^ABSPTL(IEN57,5),U,5) ; return total $amount
  1. CHG() ;EP -
  1.  Q $P(^ABSPTL(IEN57,5),U,5) ; Given IEN57, ret total charge
  1. CPTIEN() ;EP -
  1.  I $$TYPE=1 Q $O(^ABSCPT(9002300,"AVMED",$$DRGDFN,0))
  1.  ; CPT code for postage could vary by insurer and amount?
  1.  ; A complication not yet programmed
  1.  I $$TYPE=2 Q $P($G(^ABSP(9002313.99,1,"POSTAGE")),U)
  1.  I $$TYPE=3 Q $$EXTRCPT3 ; extract CPT from  visitien.cptien3
  1.  D TYPEBAD("CPTIEN")
  1.  Q ""
  1. INSIEN() ; EP -
  1.  Q $P(^ABSPTL(IEN57,1),U,6)
  1. EXTRCPT3() N X S X=IEN57,X=$P(X,".",2),X=$E(X,1,$L(X)-1) Q +X
  1. PATIENT() ;EP -
  1.  Q $P(^ABSPTL(IEN57,0),U,6)
  1. HRN() ; EP - health record number and facility abbreviation
  1.  N PAT,DIV,FAC,X
  1.  S PAT=$P($G(^ABSPTL(IEN57,0)),U,6) Q:'PAT ""
  1.  S DIV=$P($G(^ABSPTL(IEN57,1)),U,4)
  1.  I DIV S FAC=$P($G(^PS(59,DIV,"INI")),U)
  1.  E  S FAC=0
  1.  S:'FAC FAC=$G(DUZ(2))
  1.  S:'FAC FAC=$O(^AUPNPAT(PAT,41,0))
  1.  Q:'FAC ""
  1.  S X=$G(^DIC(4,FAC,0))
  1.  I $P(X,U,5)]"" S X=$P(X,U,5)
  1.  E  S X=$E($P(X,U),1,4)
  1.  Q $P($G(^AUPNPAT(PAT,41,FAC,0)),U,2)_" "_X
  1. VISITIEN() ; EP -
  1.  Q $P(^ABSPTL(IEN57,0),U,7)
  1. USER() ;EP -
  1.  N X S X=$P(^ABSPTL(IEN57,0),U,10) S:'X X=$G(DUZ) Q X
  1. TYPE() ;EP -
  1.  N X S X=$P(^ABSPTL(IEN57,0),U) ; 03/26/2001
  1.  S X=$E(X,$L(X)) ; 1=prescription, 2=postage for presc, 3=other ;
  1.  I X'=1,X'=2,X'=3 D
  1.  . D IMPOSS^ABSPOSUE("DB","TI","Bad TYPE in transaction","IEN57="_IEN57,"TYPE",$T(+0))
  1.  Q X
  1. TYPEBAD(ATLABEL) ;
  1.  D IMPOSS^ABSPOSUE("DB","TI","Invalid $$TYPE^ABSPOS57",$$TYPE,ATLABEL,$T(+0)) Q
  1. NOW() ; EP -
  1.  N %,%H,%I,X D NOW^%DTC Q %
  1. FILLDATE() ; EP -
  1.  N RXI,RXR S RXI=$$RXI,RXR=$$RXR
  1.  ;IHS/OIT/SCR 111009 patch 35 START AVOID UNDEFINED ERRORS
  1.  ;Q:RXR $P(^PSRX(RXI,1,RXR,0),U)  Q:RXI $P(^PSRX(RXI,2),U,2)
  1.  N ABSPRTRN
  1.  S ABSPRTRN=""
  1.  I ((RXI>0)&(RXR>0)) S ABSPRTRN=$P($G(^PSRX(RXI,1,RXR,0)),U) Q:ABSPRTRN'="" ABSPRTRN
  1.  I RXI>0 S ABSPRTRN=$P($G(^PSRX(RXI,2)),U,2) Q:ABSPRTRN'="" ABSPRTRN
  1.  ;IHS/OIT/SCR 111009 patch 35 END AVOID UNDEFINED ERRORS
  1.  Q $$VISDATE
  1. VISDATE() Q $P($P(^AUPNVSIT($$VISITIEN,0),U),".")
  1. VMED() ; EP -
  1.  N RXI,RXR S RXI=$$RXI,RXR=$$RXR
  1.  ;IHS/OIT/SCR 111009 patch 35 START AVOID UNDEFINED ERRORS
  1.  ;Q:RXR $P(^PSRX(RXI,1,RXR,999999911),U) Q $P(^PSRX(RXI,999999911),U)
  1.  N ABSPRTRN
  1.  S ABSPRTRN=""
  1.  I ((RXI>0)&(RXR>0)) S ABSPRTRN=$P($G(^PSRX(RXI,1,RXR,999999911)),U)
  1.  I (RXI>0) S ABSPRTRN=$P($G(^PSRX(RXI,999999911)),U)
  1.  Q ABSPRTRN
  1.  ;IHS/OIT/SCR 111009 patch 35 END AVOID UNDEFINED ERRORS
  1. PROVIDER() ;EP -
  1.  Q $P(^PSRX($$RXI,0),U,4)
  1. VCN() ;EP -
  1.  N V S V=$$VISITIEN Q:'V "" Q $P($G(^AUPNVSIT(V,"VCN")),U)
  1.  ;
  1. ISREVERS(N) ;EP - ABSPOSIY,ABSPOSM1 
  1.  ; Returns reversal claim #, else false
  1.  ; Returns 0.5 if it's reversal of a paper claim
  1.  N X S X=$G(^ABSPTL(N,4)) Q:X="" 0
  1.  I X Q $P(X,U) ; reversal of electronic claim
  1.  I $P(X,U,3) Q 0.5 ; reversal of paper claim
  1.  Q 0
  1. REVACC(N) ;EP - ABSPOSIY,ABSPOSM1
  1.  ; was this an accepted reversal? return true or false
  1.  I $P(^ABSPTL(N,4),U,3) Q 1 ; paper reversal always success
  1.  Q $$REVRESP(N)="A"
  1. REVRESP(N)         ;
  1.  ;N POSITION S POSITION=$P(^ABSPT(N,0),U,9) ; always 1?
  1.  N RESP S RESP=$P(^ABSPTL(N,4),U,2)
  1.  I 'RESP Q "?"
  1.  N X S X=$$RESP500^ABSPOSQ4(RESP,"I")
  1.  Q X ; Should be "A" or "R"
  1. ARSYSTEM()         Q $P(^ABSP(9002313.99,1,"A/R INTERFACE"),U)
  1. MAKEVCN()          ; true/false  should we assign a VCN # to the visit?
  1.  N AR S AR=$$ARSYSTEM
  1.  I AR=0 Q 1 ; yes, for ILC A/R
  1.  I AR=2 Q 1 ; yes, for ANMC A/R
  1.  Q 0 ; no, for everybody else
  1. LOG2LIST(MSG)      D LOG2LIST^ABSPOSL(MSG) Q
  1. LOG2CLM(MSG,IEN02)       D LOG2CLM^ABSPOSL(MSG,IEN02) Q
  1. LOG59(MSG) ;EP - 
  1.  D LOG59^ABSPOSL(MSG,$P(^ABSPTL(IEN57,0),U)) Q
  1. COMP59 ; devel util ; compare to .57 DD, should be same fields
  1.  W !,$T(COMP59),!
  1.  N F57,F59,OK S F57=9002313.57,F59=9002313.59,OK=1
  1.  D COMP1(F57,F59) ; everything in .57 also in .59?
  1.  W !
  1.  D COMP1(F59,F57) ; and the other direction, too
  1.  W !?5 I OK W "OK!  All fields in common"
  1.  E  W "NOT OK!  Some differences in fields"
  1.  W " between ",F57," and ",F59,!
  1.  Q
  1. COMP1(F1,F2) N A S A=0
  1.  F  S A=$O(^DD(F1,A)) Q:'A  D
  1.  . Q:$D(^DD(F2,A))  ; Okay
  1.  . I A>10000,A<11000,F1=9002313.57 Q  ; computed fields spec. for 57
  1.  . S OK=0 W "Field ",A," is in ",F1," but not in ",F2,!
  1.  Q
  1. POSITION() ; return pointer to position within claim (D1)
  1.  Q $P($G(^ABSPTL(IEN57,0)),U,9)
  1. IEN02() ; return pointer to claim 
  1.  Q $P($G(^ABSPTL(IEN57,0)),U,4)
  1. IEN03() ; return pointer to response
  1.  Q $P($G(^ABSPTL(IEN57,0)),U,5)
  1. REVIEN02() ; return pointer to reversal claim
  1.  Q $P($G(^ABSPTL(IEN57,4)),U)
  1. REVIEN03() ; return pointer to reversal response
  1.  Q $P($G(^ABSPTL(IEN57,4)),U,2)
  1. FIELD(F,REV) ; EP - retrieve field F from claim or response ; given D0
  1.  ; returns value
  1.  ; Special for reject codes:  F=511 gets ","-delimited string of codes
  1.  ;  F=511.01 gets first code, F=511.02 gets second one, etc.
  1.  N ABSPVER      ;IHS/SD/lwj 6/16/05 patch 12 claim version
  1.  N X,IEN02,IEN03,POS,IEN57 S IEN57=D0
  1.  S POS=$$POSITION,IEN02=$$IEN02,IEN03=$$IEN03
  1.  I $G(REV) S IEN02=$$REVIEN02,IEN03=$$REVIEN03
  1.  I 'IEN02,F<400 D  Q X
  1.  . S X=""
  1.  . ; could define some of them based on pricing data
  1.  I 'IEN03,F>400 D  Q X
  1.  . S X=""
  1.  I F<400 S X=$$GET1^DIQ(9002313.02,IEN02_",",F,"I")
  1.  E  I F>400,F<500 S X=$$GET1^DIQ(9002313.0201,POS_","_IEN02_",",F,"I")
  1.  E  I F=501!(F=524) S X=$$GET1^DIQ(9002313.03,IEN03_",",F,"I")
  1.  E  I F\1=511 D REJCODES S:F#1 X=$G(X(F#1*100))
  1.  E  S X=$$GET1^DIQ(9002313.0301,POS_","_IEN03_",",F,"I")
  1.  ; strip trailing spaces
  1.  F  Q:$E(X,$L(X))'=" "  S X=$E(X,1,$L(X)-1)
  1.  ;IHS/SD/lwj 6/16/05 patch 12 if version 5.1 clm rmv all fld ids
  1.  ;OIT/CAR/RCS 07052012 - Patch 44, fix so D.0 version works
  1.  S ABSPVER=$$GETVER
  1.  ;D:ABSPVER'[5 STRIPID
  1.  ;D:ABSPVER[5 STRIP51
  1.  D:ABSPVER[3 STRIPID
  1.  D:ABSPVER'[3 STRIP51
  1.  ;D STRIPID ; strip field ID, if any
  1.  ;IHS/SD/lwj 6/16/05 patch 12 end changes for this section
  1.  D MONEY ; money fields, where appropriate
  1.  D OTHER ; other special conversions
  1.  Q X
  1. REJCODES ; rejection codes for IEN03
  1.  ; X = ","-delimited string of two-char codes
  1.  ; X(j)=code_" "_description
  1.  K X S X=""
  1.  N I,J S (I,J)=0
  1.  F  S I=$O(^ABSPR(IEN03,1000,POS,511,I)) Q:'I  D
  1.  . N A S A=$P(^ABSPR(IEN03,1000,POS,511,I,0),U) Q:'A
  1.  . S A=$O(^ABSPF(9002313.93,"B",A,0)) Q:'A
  1.  . S A=^ABSPF(9002313.93,A,0)
  1.  . S:X]"" X=X_"," S X=X_$P(A,U)
  1.  . S J=J+1,X(J)=$P(A,U)_" "_$P(A,U,2)
  1.  Q
  1. STRIPID ; some fields have two-character field ID
  1.  ; and first eliminate all those that don't:
  1.  Q:F<307  Q:F=308
  1.  I F>400,F<500 Q:F<410  Q:F=411  Q:F=414  Q:F=415  Q:F=419  Q:F=420  Q:F=426
  1.  ;IHS/DSD/lwj 10/02 nxt line changed on behalf of David Slauenwhite
  1.  I F>500 Q:F<512  Q:F=525  Q:F=526  ;DS 10/11/01
  1.  S X=$E(X,3,$L(X))
  1.  Q
  1. MONEY ; some fields are money fields in signed overpunch format
  1.  Q:F<400
  1.  ;IHS/DSD/lwj 10/02 nxt line changed on behalf of David Slauenwhite
  1.  I F>400,F<500 I F'=409,F'=410,F'=426,F'=430,F'=431,F'=433,F'=438,F'=428,F'=412 Q    ;DS 10/11/01 F'=412 test added during ILC A/R interface work
  1.  I F>500 Q:F<505  Q:F=510  Q:F\1=511  Q:F=522  Q:F>523
  1.  S X=+$$DFF2EXT^ABSPECFM(X)
  1.  I X=0 S X="" ; so [CAPTIONED] doesn't print it
  1.  Q
  1. OTHER ; other special conversions
  1.  I F=442 S X=X/1000 Q  ; metric decimal quantity
  1.  Q
  1.  ;
  1. GETVER() ; check for 5.1 clm - need to rmv field ids
  1.  Q $$GET1^DIQ(9002313.02,IEN02_",",102,"E")
  1.  ;
  1. STRIP51 ;remove field ids for NCPDP 5.1,D.0 flds
  1.  N FLDLST
  1.  S FLDLST="101,102,103,104,109,110,201,202,401,"
  1.  Q:FLDLST[F_","
  1.  S X=$E(X,3,$L(X))
  1.  Q