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

ABSPOS28.m

Go to the documentation of this file. 
  1. ABSPOS28 ; IHS/FCS/DRS - test of insurance selection ; 
  1.  ;;1.0;PHARMACY POINT OF SALE;**10**;JUN 21, 2001;Build 38
  1.  ;------------------------------------------------
  1.  ;IHS/SD/lwj 03/10/04 patch 10
  1.  ; Routine adjusted to call ABSPFUNC to retrieve
  1.  ; the Prescription Refill NDC value.  At some
  1.  ; point the call needs to be modified to call APSPFUNC.
  1.  ; See ABSPFUNC for details on why call was done.
  1.  ;------------------------------------------------
  1.  Q
  1.  ; development utility
  1. TEST1(N,M,DEBUG) ; look through some prescriptions and see what you get   
  1.  ; Stores copies of ARRAY(*) in ^TMP($J,
  1.  ; See FIND* utilities below for help in searching ^TMP($J,
  1.  ;    for instances of interesting things.
  1.  ; look at N prescrips ; optionally start M from end
  1.  ; S DEBUG=1
  1.  N ABSBRXI,ABSBRXR,ABSBVISI,ABSBPATI,ABSBNDC,ABSBVMED
  1.  K ^TMP($J)
  1.  S ABSBRXI="A"
  1.  I $G(M) F IJK=1:1:M S ABSBRXI=$O(^PSRX(ABSBRXI),-1) ; skip a bit
  1.  N IJK F IJK=1:1:N D
  1.  . I IJK#100=0,'$G(DEBUG) W IJK," " W:$X>70 !
  1.  . S ABSBRXI=$O(^PSRX(ABSBRXI),-1) Q:'ABSBRXI
  1.  . S ABSBRXR=$O(^PSRX(ABSBRXI,1,"A"),-1) S:ABSBRXR="" ABSBRXR=0
  1.  . ;IHS/SD/lwj 03/10/04 patch 10, nxt line rmkd out, new line added
  1.  . ;I ABSBRXR S ABSBNDC=$P(^PSRX(ABSBRXI,1,ABSBRXR,0),"^",13)
  1.  . I ABSBRXR S ABSBNDC=$$NDCVAL^ABSPFUNC(ABSBRXI,ABSBRXR)  ;patch 10
  1.  . E  S ABSBNDC=$P(^PSRX(ABSBRXI,2),"^",7)
  1.  . ;IHS/SD/lwj 03/10/04 patch 10 end change
  1.  . I $G(DEBUG) D
  1.  . . W "- - -  for RXI=",ABSBRXI,",RXR=",ABSBRXR
  1.  . . W ", NDC=",ABSBNDC
  1.  . . W " - - -",!
  1.  . D TEST2
  1.  Q
  1. TEST2 D  ; not an entry point
  1.  . I ABSBRXR S ABSBVMED=$P($G(^PSRX(ABSBRXI,1,ABSBRXR,999999911)),U)
  1.  . E  S ABSBVMED=$P($G(^PSRX(ABSBRXI,999999911)),U)
  1.  . I 'ABSBVMED W "No PCC link for ",ABSBRXI,",",ABSBRXR,! Q
  1.  . I '$D(^AUPNVMED(ABSBVMED,0)) D  Q
  1.  . . W "PCC link but '$D() on "
  1.  . . D ZWRITE^ABSPOS("ABSBVMED") W !
  1.  . S ABSBVISI=$P(^AUPNVMED(ABSBVMED,0),U,3)
  1.  . S ABSBPATI=$P(^PSRX(ABSBRXI,0),U,2)
  1.  . N ARRAY D INSURER^ABSPOS25(.ARRAY)
  1.  . ; today, we're looking for cases with more than 1 private insurance
  1.  . M ^TMP($J,ABSBPATI,ABSBRXI,ABSBRXR)=ARRAY
  1.  . I $G(DEBUG) D ZWRITE^ABSPOS("ARRAY")
  1.  Q
  1. TEST3 ; Look through 9002313.59 entries
  1.  S ABSBRXI="A"
  1.  F  S ABSBRXI=$O(^ABSPT(ABSBRXI),-1) Q:'ABSBRXI  D
  1.  . S ABSBRXR=$P(^ABSPT(ABSBRXI,1),U)
  1.  . D TEST2
  1.  Q
  1. TEST4(PCNDFN)      ;
  1.  I PCNDFN?1N.N1"."1N.N1A D  Q  ; well, okay, we'll do a VCN too
  1.  . N VCN,X S VCN=PCNDFN,X=""
  1.  . F  S X=$O(^ABSBITMS(9002302,"V",VCN,PCNDFN)) Q:'PCNDFN  D
  1.  . . W "VCN ",VCN,", PCNDFN ",PCNDFN,!
  1.  . . D TEST4(PCNDFN)
  1.  I $L(PCNDFN,"-")=3 D  Q
  1.  . N PCN,X S PCN=PCNDFN,PCNDFN=$O(^ABSBITMS(9002302,"B",PCNDFN,0))
  1.  . W "PCN ",PCN,", PCNDFN ",PCNDFN,!
  1.  . D TEST4(PCNDFN)
  1.  N ABSBVISI S ABSBVISI=$P(^ABSBITMS(9002302,PCNDFN,1,1,0),U,3)
  1.  W "Visit date: ",$P(^AUPNVSIT(ABSBVISI,0),U),!
  1.  N ABSBPATI S ABSBPATI=$P(^ABSBITMS(9002302,PCNDFN,0),U,2)
  1.  W "Last registration update: ",$P(^AUPNPAT(ABSBPATI,0),U,3),!
  1.  N ABSBRXI,ABSBRXR S (ABSBRXI,ABSBRXR)=0
  1.  N ARRAY D INSURER^ABSPOS25(.ARRAY,1,99)
  1.  ;ZW ARRAY
  1.  N COMB M COMB=^ABSPCOMB(ABSBPATI,1) D ZWRITE^ABSPOS("COMB")
  1.  N INSCOV1 M INSCOV1=^ABSBITMS(9002302,PCNDFN,"INSCOV1")
  1.  D ZWRITE^ABSPOS("INSCOV1")
  1.  D ZWRITE^ABSPOS("ARRAY(0)")
  1.  W $P(^DPT(ABSBPATI,0),U),!
  1.  N A S A=0 F  S A=$O(ARRAY(A)) Q:'A  D
  1.  . N X S X=$P(ARRAY(A),U)
  1.  . W ARRAY(A),"     ",$P(^AUTNINS(X,0),U),!
  1.  Q
  1. SRH1 ; search for:  self pay ahead of others (the rule happened)
  1.  N INSSELF,INSCAID,INSCARE D TYPES
  1.  N A S A=0
  1.  W "Hits: "
  1.  F  S A=$O(^TMP($J,A)) Q:'A  D
  1.  . I $P(^TMP($J,A,1),U)=INSSELF,$D(^TMP($J,A,2)) D
  1.  . . ; hit!
  1.  . . W:$X>70 !?10 W A," "
  1.  W !
  1.  Q
  1. SRH2 ; search for: prvt & care & caid & ben (rule should not happen)
  1.  N INSSELF,INSCAID,INSCARE D TYPES
  1.  W "SRH2 misses: "
  1.  S A=0 F  S A=$O(^TMP($J,A)) Q:'A  D
  1.  . N X S X=$P(^TMP($J,A,1),U)
  1.  . I X'=INSSELF,X'=INSCAID,X'=INSCARE,^TMP($J,A,"BEN"),^TMP($J,A,"CARE"),^TMP($J,A,"CAID") D
  1.  . . ; hit!
  1.  . . W:$X>70 !?10 W A," "
  1.  W !
  1.  Q
  1. TYPES ;
  1.  S INSSELF=$O(^AUTNINS("B","SELF PAY",""))
  1.  S INSCAID=$O(^AUTNINS("B","MEDICAID",""))
  1.  S INSCARE=$O(^AUTNINS("B","MEDICARE",""))
  1.  Q
  1.  ; FINDxxxx in ^TMP($J,pat,rxi,rxr,n)=ARRAY(n)
  1. FINDINIT S (ABSBPATI,ABSBRXI,ABSBRXR)="" D FINDN2
  1.  I ABSBPATI="" W "There are no records",!
  1.  Q
  1. FINDNEXT S ABSBRXR=$O(^TMP($J,ABSBPATI,ABSBRXI,ABSBRXR)) Q:ABSBRXR]""
  1. FINDN1 S ABSBRXI=$O(^TMP($J,ABSBPATI,ABSBRXI)) I ABSBRXI G FINDNEXT
  1. FINDN2 S ABSBPATI=$O(^TMP($J,ABSBPATI)) I ABSBPATI G FINDN1
  1.  Q  ; ABSBPATI="" means FINDNEXT has reached the end
  1. FIND1 ; find records that have two BIRTHDAY rules
  1.  S TYPE=",1," G FINDLOOP
  1. FIND2 ; find records that have the EMPLOY2 rule
  1.  S TYPE=",2," G FINDLOOP
  1. FIND3 S TYPE=",3," G FINDLOOP ; SEARHC0 rule
  1. FIND(TYPE)         G FINDLOOP ; with TYPE set  e.g.  ,2,3,
  1. FINDLOOP D FINDINIT Q:ABSBPATI=""
  1.  W "Searching, with TYPE=",TYPE,!
  1.  F  D  D FINDNEXT Q:ABSBPATI=""
  1.  . K ARRAY M ARRAY=^TMP($J,ABSBPATI,ABSBRXI,ABSBRXR)
  1.  . K RULECT ; RULECT(rule)=count of how many times used
  1.  . N I F I=1:1:ARRAY(0) D
  1.  . . N %,X S X=ARRAY(I)
  1.  . . S %=$P(ARRAY(I),U) ; point to ^AUTNINS(%
  1.  . . S %=$P(ARRAY(I),U,2) ; PINS node
  1.  . . S %=$P(ARRAY(I),U,3) ; point into ^AUPNPRVT multiple
  1.  . . S %=$P(ARRAY(I),U,4) ; score
  1.  . . S %=$P(ARRAY(I),U,5) ; rules
  1.  . . I %]"" N J F J=1:1:$L(%,";") D
  1.  . . . N X S X=$P(%,";",J),RULECT(X)=$G(RULECT(X))+1
  1.  . I TYPE[",1,",$G(RULECT("BIRTHDAY"))>1 D FOUND(1)
  1.  . I TYPE[",2,",$G(RULECT("EMPLOY2"))>0 D FOUND(2)
  1.  . I TYPE[",3,",$G(RULECT("SEARHC0"))>0 D FOUND(3)
  1.  W "Search done",!
  1.  Q
  1. FINDTYPE(TYPE)     Q $$FINDTYPE^ABSPOS26(TYPE) ; e.g. find first PRVT, 0 if none
  1. FOUND(WHICH)       ;
  1.  W "Found case ",WHICH,!
  1.  D ZWRITE^ABSPOS("ABSBPATI","ABSBRXI","ABSBRXR","ARRAY")
  1.  Q