ABSPOSFA ; IHS/FCS/DRS - Print NCPDP claim ; [ 09/12/2002 10:08 AM ]
;;1.0;PHARMACY POINT OF SALE;**3**;JUN 21, 2001;Build 38
;----------------------------------------------------------------------
;
; This is the main routine for printing NCPDP forms.
;
; First, it calls ABSPOSFB (which calls ABSPOSFC, ABSPOSFD)
; to build an ABSP() array, just like is done for live claims.
; Then, it calls ABSPOS__ to do the actual printing.
;
Q
SORT ;EP - from ABSPOSF - Sort prescriptions into
; input: ^TMP("ABSPOSF",$J,1,ien57)="" or = insien
; output:
; ^TMP("ABSPOSF",$J,2,inskey)=insien^name^address^^city^state^zip
; ^TMP("ABSPOSF",$J,2,inskey,patkey,pharm,visitien,ien57)=""
W !,"Sorting..."
N IEN57 S IEN57=0
F S IEN57=$O(^TMP("ABSPOSF",$J,1,IEN57)) Q:'IEN57 D
. N INSNAME,INSIEN,PATIEN,PATNAME,PHARM,VISIT,INSKEY,PATKEY
. I '$D(^ABSPTL(IEN57)) Q ; transaction record disappeared?!
. ;
. ; Insurance information:
. ;
. S INSIEN=^TMP("ABSPOSF",$J,1,IEN57)
. N PCNDFN S PCNDFN=$P(^ABSPTL(IEN57,0),U,3) ; posted to ILC A/R?
. I PCNDFN S INSIEN=$$ILCINS^ABSPOSF(PCNDFN) ; use ILC insurer instead
. I 'INSIEN S INSIEN=$P(^ABSPTL(IEN57,1),U,6)
. I 'INSIEN S INSIEN=0,INSNAME="ZZZZZ NO INSURANCE"
. E S INSNAME=$P(^AUTNINS(INSIEN,0),U)
. S INSKEY=$E(INSNAME,1,20)_"#"_INSIEN
. I '$D(^TMP("ABSPOSF",$J,2,INSKEY)) D
. . N INSADDR,INSCITY,INSSTATE,INSZIP
. . I $$UNINS^ABSPOSF(INSNAME) D Q ; Bill these on statements?
. . . S INSNAME="ZZZZZ NO INSURANCE"
. . . S (INSADDR,INSCITY,INSSTATE,INSZIP)=""
. . S INSADDR=$P(^AUTNINS(INSIEN,0),U,2)
. . S INSCITY=$P(^AUTNINS(INSIEN,0),U,3)
. . S INSSTATE=$P(^AUTNINS(INSIEN,0),U,4)
. . I INSSTATE S INSSTATE=$P(^DIC(5,INSSTATE,0),U,2)
. . S INSZIP=$P(^AUTNINS(INSIEN,0),U,5)
. . S ^TMP("ABSPOSF",$J,2,INSKEY)=INSIEN_U_INSNAME_U_INSADDR_U_U_INSCITY_U_INSSTATE_U_INSZIP
. S PATIEN=$P(^ABSPTL(IEN57,0),U,6)
. S PATNAME=$P(^DPT(PATIEN,0),U)
. S VISIT=+$P(^ABSPTL(IEN57,0),U,7)
. S PHARM=+$P(^ABSPTL(IEN57,1),U,7)
. S PATKEY=$E(PATNAME,1,20)_"#"_PATIEN
. S ^TMP("ABSPOSF",$J,2,INSKEY,PATKEY,PHARM,VISIT,IEN57)=""
W !
Q
PRINT ; EP - from ABSPOSF
W !,"Print on which device?",!
N POP D ^%ZIS Q:$G(POP)
U IO
;
; Build array TRANSACT(ien)=""
; of pointers to 9002313.57
; for the transactions for which to print forms.
;
; then for each pair, D PRINT^ABSPOSFP
N INSNAME,PATNAME,PHARM,VISITIEN,IEN57
S INSNAME=""
F S INSNAME=$O(^TMP("ABSPOSF",$J,2,INSNAME)) Q:INSNAME="" D
. Q:INSFIRST]INSNAME ; EPILC needs this test here
. I '$$TOSCREEN^ABSPOSU5 D
. . U $P
. . W "Printing for ",INSNAME,!
. . U IO
. S PATNAME=""
. F S PATNAME=$O(^TMP("ABSPOSF",$J,2,INSNAME,PATNAME)) Q:PATNAME="" D
. . S PHARM=""
. . F S PHARM=$O(^TMP("ABSPOSF",$J,2,INSNAME,PATNAME,PHARM)) Q:PHARM="" D
. . . D VISITS
D ^%ZISC
Q
VISITS ; at ^TMP("ABSPOSF",$J,2,INSNAME,PATNAME,PHARM)
S VISITIEN=""
F S VISITIEN=$O(^TMP("ABSPOSF",$J,2,INSNAME,PATNAME,PHARM,VISITIEN)) Q:VISITIEN="" D
. N TRANSACT
. M TRANSACT=^TMP("ABSPOSF",$J,2,INSNAME,PATNAME,PHARM,VISITIEN)
. D PRINTV(^TMP("ABSPOSF",$J,2,INSNAME))
Q
PRINTV(INSINFO) ; we have TRANSACT(ien57)="" for a bunch of prescriptions
; INSINFO=INSIEN^NAME^ADDR 1^ADDR 2^CITY^STATE^ZIP
N ABSP,NCPDP
Q:$$ABSP^ABSPOSFB'=0 ; builds ABSP() array for these transactions
; augment ABSP() with insurance name and address
S ABSP("Insurer","Name")=$P(INSINFO,U,2)
S ABSP("Insurer","Addr 1")=$P(INSINFO,U,3)
S ABSP("Insurer","Addr 2")=$P(INSINFO,U,4)
S ABSP("Insurer","City")=$P(INSINFO,U,5)
S ABSP("Insurer","State")=$P(INSINFO,U,6)
S ABSP("Insurer","Zip")=$P(INSINFO,U,7)
D NCPDP ; builds NCPDP() array ; with overrides as appropriate
; NCPDP(field #)=value ; NCPDP("RX",rxn,field#)=value
D PRINT^ABSPOSFP ; output the ABSP(*) and NCPDP(*) arrays onto form(s)
Q
NCPDP ; Build NCPDP(field #)=value
; NCPDP("RX",rxn,field #)=value
; Loop through every NCPDP field and Xecute the "Get" code.
; (checking for overrides, in which case the "Get" doesn't happen)
; Then store the result in the NCPDP array, as above.
; Note that we will have EVERY field defined, even if value is null.
N RXN,FIELDNUM,FIELDIEN S FIELDNUM=0
F S FIELDNUM=$O(^ABSPF(9002313.91,"B",FIELDNUM)) Q:'FIELDNUM D
. I FIELDNUM<200 Q ; BIN, Version, Transaction Code are n/a
. S FIELDIEN=$O(^ABSPF(9002313.91,"B",FIELDNUM,0))
. I FIELDNUM<400 D ; Claim Header field - just once for all
. . I $D(ABSP("OVERRIDE",FIELDNUM)) D
. . . S ABSP("X")=ABSP("OVERRIDE",FIELDNUM)
. . E D
. . . D NCPDP1
. . S NCPDP(FIELDNUM)=ABSP("X")
. . K ABSP("X")
. E D ; Claim Information field - once per prescription
. . N RXN S RXN=0
. . F S RXN=$O(ABSP("RX",RXN)) Q:'RXN D
. . . I $D(ABSP("OVERRIDE","RX",RXN,FIELDNUM)) D
. . . . S ABSP("X")=ABSP("OVERRIDE","RX",RXN,FIELDNUM)
. . . E D
. . . . S ABSP(9002313.0201)=RXN
. . . . D NCPDP1
. . . S NCPDP("RX",RXN,FIELDNUM)=ABSP("X")
. . K ABSP(9002313.0201),ABSP("X")
Q
NCPDP1 ;
N D1 S D1=0,ABSP("X")=""
F S D1=$O(^ABSPF(9002313.91,FIELDIEN,10,D1)) Q:'D1 D
. X ^ABSPF(9002313.91,FIELDIEN,10,D1,0)
Q ; with ABSP("X") set up
TEST ; a test - find a bunch of recent transactions
; and set up ^TMP("ABSPOSF",$J,1,IEN57)
K ^TMP("ABSPOSF",$J)
N IEN57 S IEN57=$P(^ABSPTL(0),U,3)+1 ; setup for $O in reverse
N NTRANS S NTRANS=2 ; take two transactions
F D Q:'NTRANS Q:'IEN57
. S IEN57=$O(^ABSPTL(IEN57),-1) Q:'IEN57
. ; don't take ones that went electronic transactions
. ; (though there's no real reason we couldn't)
. I $$GET1^DIQ(9002313.57,IEN57_",","RESULT WITH REVERSAL")?1"E ".E Q
. N INS S INS=$P(^ABSPTL(IEN57,1),U,6)
. Q:'INS Q:$$UNINS^ABSPOSF($P(^AUTNINS(INS,0),U)) ;
. S ^TMP("ABSPOSF",$J,1,IEN57)="",NTRANS=NTRANS-1 ; YES add to list
W "Sorting..." D SORT W !
D
. W "results of SORT:",!
. N TMP M TMP=^TMP("ABSPOSF",$J) D ZWRITE^ABSPOS("TMP")
W "Printing..." W ! D PRINT W ! ; print to current device; capture
Q
ABSPOSFA ; IHS/FCS/DRS - Print NCPDP claim ; [ 09/12/2002 10:08 AM ]
+1 ;;1.0;PHARMACY POINT OF SALE;**3**;JUN 21, 2001;Build 38
+2 ;----------------------------------------------------------------------
+3 ;
+4 ; This is the main routine for printing NCPDP forms.
+5 ;
+6 ; First, it calls ABSPOSFB (which calls ABSPOSFC, ABSPOSFD)
+7 ; to build an ABSP() array, just like is done for live claims.
+8 ; Then, it calls ABSPOS__ to do the actual printing.
+9 ;
+10 QUIT
SORT ;EP - from ABSPOSF - Sort prescriptions into
+1 ; input: ^TMP("ABSPOSF",$J,1,ien57)="" or = insien
+2 ; output:
+3 ; ^TMP("ABSPOSF",$J,2,inskey)=insien^name^address^^city^state^zip
+4 ; ^TMP("ABSPOSF",$J,2,inskey,patkey,pharm,visitien,ien57)=""
+5 WRITE !,"Sorting..."
+6 NEW IEN57
SET IEN57=0
+7 FOR
SET IEN57=$ORDER(^TMP("ABSPOSF",$JOB,1,IEN57))
IF 'IEN57
QUIT
Begin DoDot:1
+8 NEW INSNAME,INSIEN,PATIEN,PATNAME,PHARM,VISIT,INSKEY,PATKEY
+9 ; transaction record disappeared?!
IF '$DATA(^ABSPTL(IEN57))
QUIT
+10 ;
+11 ; Insurance information:
+12 ;
+13 SET INSIEN=^TMP("ABSPOSF",$JOB,1,IEN57)
+14 ; posted to ILC A/R?
NEW PCNDFN
SET PCNDFN=$PIECE(^ABSPTL(IEN57,0),U,3)
+15 ; use ILC insurer instead
IF PCNDFN
SET INSIEN=$$ILCINS^ABSPOSF(PCNDFN)
+16 IF 'INSIEN
SET INSIEN=$PIECE(^ABSPTL(IEN57,1),U,6)
+17 IF 'INSIEN
SET INSIEN=0
SET INSNAME="ZZZZZ NO INSURANCE"
+18 IF '$TEST
SET INSNAME=$PIECE(^AUTNINS(INSIEN,0),U)
+19 SET INSKEY=$EXTRACT(INSNAME,1,20)_"#"_INSIEN
+20 IF '$DATA(^TMP("ABSPOSF",$JOB,2,INSKEY))
Begin DoDot:2
+21 NEW INSADDR,INSCITY,INSSTATE,INSZIP
+22 ; Bill these on statements?
IF $$UNINS^ABSPOSF(INSNAME)
Begin DoDot:3
+23 SET INSNAME="ZZZZZ NO INSURANCE"
+24 SET (INSADDR,INSCITY,INSSTATE,INSZIP)=""
End DoDot:3
QUIT
+25 SET INSADDR=$PIECE(^AUTNINS(INSIEN,0),U,2)
+26 SET INSCITY=$PIECE(^AUTNINS(INSIEN,0),U,3)
+27 SET INSSTATE=$PIECE(^AUTNINS(INSIEN,0),U,4)
+28 IF INSSTATE
SET INSSTATE=$PIECE(^DIC(5,INSSTATE,0),U,2)
+29 SET INSZIP=$PIECE(^AUTNINS(INSIEN,0),U,5)
+30 SET ^TMP("ABSPOSF",$JOB,2,INSKEY)=INSIEN_U_INSNAME_U_INSADDR_U_U_INSCITY_U_INSSTATE_U_INSZIP
End DoDot:2
+31 SET PATIEN=$PIECE(^ABSPTL(IEN57,0),U,6)
+32 SET PATNAME=$PIECE(^DPT(PATIEN,0),U)
+33 SET VISIT=+$PIECE(^ABSPTL(IEN57,0),U,7)
+34 SET PHARM=+$PIECE(^ABSPTL(IEN57,1),U,7)
+35 SET PATKEY=$EXTRACT(PATNAME,1,20)_"#"_PATIEN
+36 SET ^TMP("ABSPOSF",$JOB,2,INSKEY,PATKEY,PHARM,VISIT,IEN57)=""
End DoDot:1
+37 WRITE !
+38 QUIT
PRINT ; EP - from ABSPOSF
+1 WRITE !,"Print on which device?",!
+2 NEW POP
DO ^%ZIS
IF $GET(POP)
QUIT
+3 USE IO
+4 ;
+5 ; Build array TRANSACT(ien)=""
+6 ; of pointers to 9002313.57
+7 ; for the transactions for which to print forms.
+8 ;
+9 ; then for each pair, D PRINT^ABSPOSFP
+10 NEW INSNAME,PATNAME,PHARM,VISITIEN,IEN57
+11 SET INSNAME=""
+12 FOR
SET INSNAME=$ORDER(^TMP("ABSPOSF",$JOB,2,INSNAME))
IF INSNAME=""
QUIT
Begin DoDot:1
+13 ; EPILC needs this test here
IF INSFIRST]INSNAME
QUIT
+14 IF '$$TOSCREEN^ABSPOSU5
Begin DoDot:2
+15 USE $PRINCIPAL
+16 WRITE "Printing for ",INSNAME,!
+17 USE IO
End DoDot:2
+18 SET PATNAME=""
+19 FOR
SET PATNAME=$ORDER(^TMP("ABSPOSF",$JOB,2,INSNAME,PATNAME))
IF PATNAME=""
QUIT
Begin DoDot:2
+20 SET PHARM=""
+21 FOR
SET PHARM=$ORDER(^TMP("ABSPOSF",$JOB,2,INSNAME,PATNAME,PHARM))
IF PHARM=""
QUIT
Begin DoDot:3
+22 DO VISITS
End DoDot:3
End DoDot:2
End DoDot:1
+23 DO ^%ZISC
+24 QUIT
VISITS ; at ^TMP("ABSPOSF",$J,2,INSNAME,PATNAME,PHARM)
+1 SET VISITIEN=""
+2 FOR
SET VISITIEN=$ORDER(^TMP("ABSPOSF",$JOB,2,INSNAME,PATNAME,PHARM,VISITIEN))
IF VISITIEN=""
QUIT
Begin DoDot:1
+3 NEW TRANSACT
+4 MERGE TRANSACT=^TMP("ABSPOSF",$JOB,2,INSNAME,PATNAME,PHARM,VISITIEN)
+5 DO PRINTV(^TMP("ABSPOSF",$JOB,2,INSNAME))
End DoDot:1
+6 QUIT
PRINTV(INSINFO) ; we have TRANSACT(ien57)="" for a bunch of prescriptions
+1 ; INSINFO=INSIEN^NAME^ADDR 1^ADDR 2^CITY^STATE^ZIP
+2 NEW ABSP,NCPDP
+3 ; builds ABSP() array for these transactions
IF $$ABSP^ABSPOSFB'=0
QUIT
+4 ; augment ABSP() with insurance name and address
+5 SET ABSP("Insurer","Name")=$PIECE(INSINFO,U,2)
+6 SET ABSP("Insurer","Addr 1")=$PIECE(INSINFO,U,3)
+7 SET ABSP("Insurer","Addr 2")=$PIECE(INSINFO,U,4)
+8 SET ABSP("Insurer","City")=$PIECE(INSINFO,U,5)
+9 SET ABSP("Insurer","State")=$PIECE(INSINFO,U,6)
+10 SET ABSP("Insurer","Zip")=$PIECE(INSINFO,U,7)
+11 ; builds NCPDP() array ; with overrides as appropriate
DO NCPDP
+12 ; NCPDP(field #)=value ; NCPDP("RX",rxn,field#)=value
+13 ; output the ABSP(*) and NCPDP(*) arrays onto form(s)
DO PRINT^ABSPOSFP
+14 QUIT
NCPDP ; Build NCPDP(field #)=value
+1 ; NCPDP("RX",rxn,field #)=value
+2 ; Loop through every NCPDP field and Xecute the "Get" code.
+3 ; (checking for overrides, in which case the "Get" doesn't happen)
+4 ; Then store the result in the NCPDP array, as above.
+5 ; Note that we will have EVERY field defined, even if value is null.
+6 NEW RXN,FIELDNUM,FIELDIEN
SET FIELDNUM=0
+7 FOR
SET FIELDNUM=$ORDER(^ABSPF(9002313.91,"B",FIELDNUM))
IF 'FIELDNUM
QUIT
Begin DoDot:1
+8 ; BIN, Version, Transaction Code are n/a
IF FIELDNUM<200
QUIT
+9 SET FIELDIEN=$ORDER(^ABSPF(9002313.91,"B",FIELDNUM,0))
+10 ; Claim Header field - just once for all
IF FIELDNUM<400
Begin DoDot:2
+11 IF $DATA(ABSP("OVERRIDE",FIELDNUM))
Begin DoDot:3
+12 SET ABSP("X")=ABSP("OVERRIDE",FIELDNUM)
End DoDot:3
+13 IF '$TEST
Begin DoDot:3
+14 DO NCPDP1
End DoDot:3
+15 SET NCPDP(FIELDNUM)=ABSP("X")
+16 KILL ABSP("X")
End DoDot:2
+17 ; Claim Information field - once per prescription
IF '$TEST
Begin DoDot:2
+18 NEW RXN
SET RXN=0
+19 FOR
SET RXN=$ORDER(ABSP("RX",RXN))
IF 'RXN
QUIT
Begin DoDot:3
+20 IF $DATA(ABSP("OVERRIDE","RX",RXN,FIELDNUM))
Begin DoDot:4
+21 SET ABSP("X")=ABSP("OVERRIDE","RX",RXN,FIELDNUM)
End DoDot:4
+22 IF '$TEST
Begin DoDot:4
+23 SET ABSP(9002313.0201)=RXN
+24 DO NCPDP1
End DoDot:4
+25 SET NCPDP("RX",RXN,FIELDNUM)=ABSP("X")
End DoDot:3
+26 KILL ABSP(9002313.0201),ABSP("X")
End DoDot:2
End DoDot:1
+27 QUIT
NCPDP1 ;
+1 NEW D1
SET D1=0
SET ABSP("X")=""
+2 FOR
SET D1=$ORDER(^ABSPF(9002313.91,FIELDIEN,10,D1))
IF 'D1
QUIT
Begin DoDot:1
+3 XECUTE ^ABSPF(9002313.91,FIELDIEN,10,D1,0)
End DoDot:1
+4 ; with ABSP("X") set up
QUIT
TEST ; a test - find a bunch of recent transactions
+1 ; and set up ^TMP("ABSPOSF",$J,1,IEN57)
+2 KILL ^TMP("ABSPOSF",$JOB)
+3 ; setup for $O in reverse
NEW IEN57
SET IEN57=$PIECE(^ABSPTL(0),U,3)+1
+4 ; take two transactions
NEW NTRANS
SET NTRANS=2
+5 FOR
Begin DoDot:1
+6 SET IEN57=$ORDER(^ABSPTL(IEN57),-1)
IF 'IEN57
QUIT
+7 ; don't take ones that went electronic transactions
+8 ; (though there's no real reason we couldn't)
+9 IF $$GET1^DIQ(9002313.57,IEN57_",","RESULT WITH REVERSAL")?1"E ".E
QUIT
+10 NEW INS
SET INS=$PIECE(^ABSPTL(IEN57,1),U,6)
+11 ;
IF 'INS
QUIT
IF $$UNINS^ABSPOSF($PIECE(^AUTNINS(INS,0),U))
QUIT
+12 ; YES add to list
SET ^TMP("ABSPOSF",$JOB,1,IEN57)=""
SET NTRANS=NTRANS-1
End DoDot:1
IF 'NTRANS
QUIT
IF 'IEN57
QUIT
+13 WRITE "Sorting..."
DO SORT
WRITE !
+14 Begin DoDot:1
+15 WRITE "results of SORT:",!
+16 NEW TMP
MERGE TMP=^TMP("ABSPOSF",$JOB)
DO ZWRITE^ABSPOS("TMP")
End DoDot:1
+17 ; print to current device; capture
WRITE "Printing..."
WRITE !
DO PRINT
WRITE !
+18 QUIT
