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