ABSPOSQ2 ; IHS/FCS/DRS - form transmission packets ; [ 11/07/2002 6:57 AM ]
;;1.0;PHARMACY POINT OF SALE;**3,31,42**;JUN 01, 2001;Build 38
;
; Status comes in as 30. Or as 31.
; Status set to 40 which PACKET() is in progress.
; When PACKET() is done, the status is changed to 50
; The transmission packet is in ^ABSPECX("POS",DIALOUT,"C",*)
; and ABSPOSQ3 is scheduled to do the transmission.
;
; Split-off code:
; STATUS31^ABSPOSQF - Insurer asleep condition is handled here
; PACKET^ABSPOSQG - packetizing RXILIST(*)
;
;----------------------------------------------------------------
; IHS/SD/lwj 8/5/02 NCPDP 5.1 changes
; Prior Authorization claims must now be sent one by one - no
; bundling allowed. New logic added before bundling to check
; the overrides for field 498.01 (Request Type), 498.02 (Request
; period date-begin), 498.03 (Request period date-end), and 498.04
; (basis of request). These four fields are required for a prior
; authorization claim, and if we encounter even one of the fields
; we will keep the claim from bundling.
;
;
PACKETS ; construct packets for transmission to NDC
; your work list is ^ABSPT("AD",30)
;
; LOGGING: Do NOT keep a "current" slot.
; When you need to log something, use one of these routines:
; LOG59^ABSPOSQ(MSG,IEN59) - log MSG to this one slot
; LOG2LIST^ABSPOSQ(MSG) - log MSG to all on RXILIST(*)
; LOG2CLM^ABSPOSQ(MSG,IEN02) - log MSG to all on this 9002313.02 claim
;
N ERROR,SILENT S SILENT=1
N RXILIST,STATUS30
D STATUS31^ABSPOSQF ; deal with insurer alseep waiting
F STATUS30=30 I $D(^ABSPT("AD",STATUS30)) D STATUS30
; If there are still any claims with status 30,
; perhaps due to failed LOCK59, queue up ABSPOSQ2 to run again
N NEEDQ1 S NEEDQ1=$O(^ABSPT("AD",30,0))
; Don't worry about status 31 - retry after insurer asleep
; was already scheduled, when the response packet came.
;I 'NEEDQ1 S NEEDQ1=$O(^ABSPT("AD",31,0))
I NEEDQ1 H 60 D TASK^ABSPOSQ1
Q
SETSTAT(NEWSTAT) ;EP - ABSPOSQF ; given IEN59
N ABSBRXI S ABSBRXI=IEN59 ; unfortunate variable naming convention
D SETSTAT^ABSPOSU(NEWSTAT)
Q
SETRESU(RESCODE,TEXT) ; given IEN59
N ABSBRXI S ABSBRXI=IEN59 ; unfortunate variable naming convention
D SETRESU^ABSPOSU(RESCODE,TEXT)
Q
; Locking and unlocking the list of claims with
; with STATUS30=30 or 31. The lock should always succeed.
; But since it's required to be a timed lock, LOCK59 is a $$,
; true if successful, false if failure.
LOCK59() ;EP - ABSPOSQF
L +^ABSPT("AD",STATUS30):60 Q $T
UNLOCK59 ;EP - ABSPOSQF
L -^ABSPT("AD",STATUS30) Q
NEXT59(X) ;EP - ABSPOSQF
N INS,T
N59A S X=$O(^ABSPT("AD",STATUS30,X))
I X="" Q X ; end of list, return ""
; but if the insurer is asleep, don't take this one
S INS=$P(^ABSPT(X,1),U,6)
I $G(INS)="" Q X ;IHS/OIT/SCR 05/12/09 patch 31 avoid undefined
I '$D(^ABSPEI(INS)) Q X ;IHS/OIT/RAN 03/31/2011 patch 42 avoid undefined
S T=$P($G(^ABSPEI(INS,101)),U) ; insurer asleep retry time
I 'T Q X ; insurer is not asleep
; - below here - insurer is asleep -
; If cancellation is requested, let it through, regardless of sleep.
; This will speed it on its way to cancellation
I $G(^ABSPT(X,3)) Q X
; If necessary, update the .59's record of when to retry
I $P($G(^ABSPT(X,8)),U)'=T D ;
. S $P(^ABSPT(X,8),U)=T ; stamp with latest retry time
. N IEN59 S IEN59=X D SETSTAT(31) ; force screen update, too
. D LOG59^ABSPOSQ("Insurer still asleep - retry at "_T,IEN59)
I T<$$NOW Q X ; time to retry, so yes, we do this one
;. don't clear this - a successful non-sleep response will clear it
;. S $P(^ABSPEI(INS,101),U)="" ; clear the sleep-until time
;. but don't clear the piece 5 current interval, as we may increment
; Else still in waiting - if it's status 30, change it to 31
I STATUS30=30 D
. N IEN59 S IEN59=X D SETSTAT(31)
. S $P(^ABSPT(IEN59,8),U)=$P(^ABSPEI(INS,101),U)
. S $P(^ABSPT(IEN59,8),U,3)=INS
G N59A ; still in wait time; don't look at this claim
NOW() N %,%H,%I,X D NOW^%DTC Q %
STATUS30 ; given STATUS30=30
N IEN59 S IEN59=""
Q:'$$LOCK59
F S IEN59=$$NEXT59(IEN59) Q:IEN59="" D
. K RXILIST ; init list each time through this loop
. S RXILIST(IEN59)=""
. D SETSTAT(40) ; set its status to "packetizing"
.; Reversals go in a packet alone
. I $G(^ABSPT(IEN59,4)) G POINTX
.;
.;IHS/SD/lwj 8/5/02 NCPDP 5.1 - claim cannot be bundled if
.; there is prior authorization information
.; use CHKPA when the processor are ready to use the actual
.; prior authorization segment - for now, use the CHKPA2
.; G:$$CHKPA() POINTX
. G:$$CHKPA2() POINTX
.;
.; Who is the patient? Find all other prescriptions for this
.; patient which have status 30, and add them to the RXILIST, too
.; Must also have same VISIT and same DIVISION
.;
. N RA0,RA1 S RA0=^ABSPT(IEN59,0),RA1=^(1)
. N IEN59 S IEN59="" ; preserve the top-level index!
. F S IEN59=$$NEXT59(IEN59) Q:'IEN59 D
. . N RB0,RB1 S RB0=^ABSPT(IEN59,0),RB1=^(1)
. . ; Only bundle when you have the same:
. . ; Patient, Visit, Division, Division Source, Insurer, Pharmacy
. . I $P(RA0,U,6,7)'=$P(RB0,U,6,7) Q
. . I $P(RA1,U,4,7)'=$P(RB1,U,4,7) Q
. . I $P(RB0,U,2)'=30 Q ; might have been canceled, or maybe 31'd
. . I $P(RB0,U,2)'=STATUS30 D Q
. . . D IMPOSS^ABSPOSUE("P","TI","IEN59 status "_$P(RB0,U,2)_" but must be 30",,"STATUS30",$T(+0))
. . D SETSTAT(40)
. . S RXILIST(IEN59)=""
POINTX . ; (reversals branch here around multi-claim packeting)
. ;
. ; so now we have a big list of prescriptions, RXILIST(*)
. ; they're all marked with status = 40 PACKETIZING
. ; Get going - packetize them!
. ;
. S ERROR=$$PACKET^ABSPOSQG ;
. ;
. ; Having packetized, reset status to 50, Waiting for transmit
. ; There should never be an error returned by $$PACKET,
. ; although it could happen.
. ; But if there was an error, reset the status to 99 right now.
. ; And set that status for every prescription in the RXILIST,
. ; even if maybe only one of them caused all the trouble.
. ;
. S IEN59="" F S IEN59=$O(RXILIST(IEN59)) Q:IEN59="" D
. . I ERROR D
. . . D SETSTAT(99) ;
. . . D SETRESU($P(ERROR,U),$P(ERROR,U,2,$L(ERROR,U))) ;
. . E D
. . . D SETSTAT(50) ; "Waiting for transmit"
D UNLOCK59
Q
;
; TASK^ABSPOSQ2 starts up a sender-receiver in ABSPOSQ3.
; TASK is an entry point used by POKE^ABSPOS2D
; It may well be called from other places in the future,
; if we try to be clever and start the dialing while we're getting
; claim information together, for instance.
;
TASK ;EP - ABSPOS2D,ABSPOSAP,ABSPOSC3,ABSPOSQG
N X,Y,%DT
S X="N",%DT="ST" D ^%DT
D TASKAT(Y)
Q
TASKAT(ZTDTH) ;EP - ABSPOSQJ
;ZTDTH = time when you want COMMS^ABSPOSQ3 to run
; called from TASK, above, normally
; called here from ABSPOSQ3 when it's requeueing itself for
; retry after a dial-out error condition
;N (DUZ,DIALOUT,TIME,ZTDTH)
N ZTRTN,ZTIO,ZTSAVE
S ZTRTN="COMMS^ABSPOSQ3",ZTIO=""
S ZTSAVE("DIALOUT")="" ; which entry in 9002313.55
D ^%ZTLOAD
Q
KSCRATCH ;EP - ABSPOSQG ; Kill scratch globals
K ^ABSPECX($J,"R")
K ^ABSPECX($J,"C")
Q
;
CHKPA() ;---------------------------------------------------------------
;IHS/SD/lwj 8/30/02 NCPDP 5.1 - we aren't quite ready for this
; yet - the below logic is going to work with the actual
; prior authorization segment, and no one is going to use that
; or support that segment for a while. SO.....I'm leaving this
; here for future reference - BUT for now, we're going to use
; the CHKPA2 routine to simply check for field 461 and 461.
;*
;IHS/SD/lwj 8/5/02 NCPDP 5.1 If any of the following fields
; appear as an override on this claim, we must consider it a prior
; authorization claim, and it cannot be bundled with other claims.
; 498.01 Request Type
; 498.02 Request Period Date Begin
; 498.03 Request Period Date End
; 498.04 Basis of Request
;
N OVRREC,OVRFLD,NCPDPF,NCPDPFN,PACLM
S PACLM=0
;
S OVRREC=$P($G(^ABSPT(IEN59,1)),U,13) ;grab the overrides
Q:OVRREC="" 0 ;no overrides - can't be a prior auth claim
;
; loop through the overrides and look for the prior auth fields
S OVRFLD=0
F S OVRFLD=$O(^ABSP(9002313.511,OVRREC,1,OVRFLD)) Q:'+OVRFLD D
. S NCPDPF=$P($G(^ABSP(9002313.511,OVRREC,1,OVRFLD,0)),U) ;int fld
. S NCPDPFN=$P($G(^ABSPF(9002313.91,NCPDPF,0)),U) ;fld number
. Q:(NCPDPFN<498.01)!(NCPDPFN>498.04)
. S PACLM=1
;
Q PACLM
;
CHKPA2() ;---------------------------------------------------------------
; IHS/SD/lwj 8/30/02 NCPDP 5.1
;Until processors are ready to use the prior authorization
; segment, we are going to use this routine to check for
; a prior authorization. To do this we will simply check
; for field 461 (Prior Authorization type code) and field
; 462 (Prior Authorization Number Submitted)
; If either exist, we will not bundle the claim. Prior
; authorization claims must be sent on their own.
;*
;
N PATYP,PANUM
S PACLM=0
;
S PATYP=$P($G(^ABSPT(IEN59,1)),U,15) ;prior auth type code
S PANUM=$P($G(^ABSPT(IEN59,1)),U,9) ;prior auth number
I ($G(PATYP)'="")!($G(PANUM)'="") S PACLM=1
;
Q PACLM
ABSPOSQ2 ; IHS/FCS/DRS - form transmission packets ; [ 11/07/2002 6:57 AM ]
+1 ;;1.0;PHARMACY POINT OF SALE;**3,31,42**;JUN 01, 2001;Build 38
+2 ;
+3 ; Status comes in as 30. Or as 31.
+4 ; Status set to 40 which PACKET() is in progress.
+5 ; When PACKET() is done, the status is changed to 50
+6 ; The transmission packet is in ^ABSPECX("POS",DIALOUT,"C",*)
+7 ; and ABSPOSQ3 is scheduled to do the transmission.
+8 ;
+9 ; Split-off code:
+10 ; STATUS31^ABSPOSQF - Insurer asleep condition is handled here
+11 ; PACKET^ABSPOSQG - packetizing RXILIST(*)
+12 ;
+13 ;----------------------------------------------------------------
+14 ; IHS/SD/lwj 8/5/02 NCPDP 5.1 changes
+15 ; Prior Authorization claims must now be sent one by one - no
+16 ; bundling allowed. New logic added before bundling to check
+17 ; the overrides for field 498.01 (Request Type), 498.02 (Request
+18 ; period date-begin), 498.03 (Request period date-end), and 498.04
+19 ; (basis of request). These four fields are required for a prior
+20 ; authorization claim, and if we encounter even one of the fields
+21 ; we will keep the claim from bundling.
+22 ;
+23 ;
PACKETS ; construct packets for transmission to NDC
+1 ; your work list is ^ABSPT("AD",30)
+2 ;
+3 ; LOGGING: Do NOT keep a "current" slot.
+4 ; When you need to log something, use one of these routines:
+5 ; LOG59^ABSPOSQ(MSG,IEN59) - log MSG to this one slot
+6 ; LOG2LIST^ABSPOSQ(MSG) - log MSG to all on RXILIST(*)
+7 ; LOG2CLM^ABSPOSQ(MSG,IEN02) - log MSG to all on this 9002313.02 claim
+8 ;
+9 NEW ERROR,SILENT
SET SILENT=1
+10 NEW RXILIST,STATUS30
+11 ; deal with insurer alseep waiting
DO STATUS31^ABSPOSQF
+12 FOR STATUS30=30
IF $DATA(^ABSPT("AD",STATUS30))
DO STATUS30
+13 ; If there are still any claims with status 30,
+14 ; perhaps due to failed LOCK59, queue up ABSPOSQ2 to run again
+15 NEW NEEDQ1
SET NEEDQ1=$ORDER(^ABSPT("AD",30,0))
+16 ; Don't worry about status 31 - retry after insurer asleep
+17 ; was already scheduled, when the response packet came.
+18 ;I 'NEEDQ1 S NEEDQ1=$O(^ABSPT("AD",31,0))
+19 IF NEEDQ1
HANG 60
DO TASK^ABSPOSQ1
+20 QUIT
SETSTAT(NEWSTAT) ;EP - ABSPOSQF ; given IEN59
+1 ; unfortunate variable naming convention
NEW ABSBRXI
SET ABSBRXI=IEN59
+2 DO SETSTAT^ABSPOSU(NEWSTAT)
+3 QUIT
SETRESU(RESCODE,TEXT) ; given IEN59
+1 ; unfortunate variable naming convention
NEW ABSBRXI
SET ABSBRXI=IEN59
+2 DO SETRESU^ABSPOSU(RESCODE,TEXT)
+3 QUIT
+4 ; Locking and unlocking the list of claims with
+5 ; with STATUS30=30 or 31. The lock should always succeed.
+6 ; But since it's required to be a timed lock, LOCK59 is a $$,
+7 ; true if successful, false if failure.
LOCK59() ;EP - ABSPOSQF
+1 LOCK +^ABSPT("AD",STATUS30):60
QUIT $TEST
UNLOCK59 ;EP - ABSPOSQF
+1 LOCK -^ABSPT("AD",STATUS30)
QUIT
NEXT59(X) ;EP - ABSPOSQF
+1 NEW INS,T
N59A SET X=$ORDER(^ABSPT("AD",STATUS30,X))
+1 ; end of list, return ""
IF X=""
QUIT X
+2 ; but if the insurer is asleep, don't take this one
+3 SET INS=$PIECE(^ABSPT(X,1),U,6)
+4 ;IHS/OIT/SCR 05/12/09 patch 31 avoid undefined
IF $GET(INS)=""
QUIT X
+5 ;IHS/OIT/RAN 03/31/2011 patch 42 avoid undefined
IF '$DATA(^ABSPEI(INS))
QUIT X
+6 ; insurer asleep retry time
SET T=$PIECE($GET(^ABSPEI(INS,101)),U)
+7 ; insurer is not asleep
IF 'T
QUIT X
+8 ; - below here - insurer is asleep -
+9 ; If cancellation is requested, let it through, regardless of sleep.
+10 ; This will speed it on its way to cancellation
+11 IF $GET(^ABSPT(X,3))
QUIT X
+12 ; If necessary, update the .59's record of when to retry
+13 ;
IF $PIECE($GET(^ABSPT(X,8)),U)'=T
Begin DoDot:1
+14 ; stamp with latest retry time
SET $PIECE(^ABSPT(X,8),U)=T
+15 ; force screen update, too
NEW IEN59
SET IEN59=X
DO SETSTAT(31)
+16 DO LOG59^ABSPOSQ("Insurer still asleep - retry at "_T,IEN59)
End DoDot:1
+17 ; time to retry, so yes, we do this one
IF T<$$NOW
QUIT X
+18 ;. don't clear this - a successful non-sleep response will clear it
+19 ;. S $P(^ABSPEI(INS,101),U)="" ; clear the sleep-until time
+20 ;. but don't clear the piece 5 current interval, as we may increment
+21 ; Else still in waiting - if it's status 30, change it to 31
+22 IF STATUS30=30
Begin DoDot:1
+23 NEW IEN59
SET IEN59=X
DO SETSTAT(31)
+24 SET $PIECE(^ABSPT(IEN59,8),U)=$PIECE(^ABSPEI(INS,101),U)
+25 SET $PIECE(^ABSPT(IEN59,8),U,3)=INS
End DoDot:1
+26 ; still in wait time; don't look at this claim
GOTO N59A
NOW() NEW %,%H,%I,X
DO NOW^%DTC
QUIT %
STATUS30 ; given STATUS30=30
+1 NEW IEN59
SET IEN59=""
+2 IF '$$LOCK59
QUIT
+3 FOR
SET IEN59=$$NEXT59(IEN59)
IF IEN59=""
QUIT
Begin DoDot:1
+4 ; init list each time through this loop
KILL RXILIST
+5 SET RXILIST(IEN59)=""
+6 ; set its status to "packetizing"
DO SETSTAT(40)
+7 ; Reversals go in a packet alone
+8 IF $GET(^ABSPT(IEN59,4))
GOTO POINTX
+9 ;
+10 ;IHS/SD/lwj 8/5/02 NCPDP 5.1 - claim cannot be bundled if
+11 ; there is prior authorization information
+12 ; use CHKPA when the processor are ready to use the actual
+13 ; prior authorization segment - for now, use the CHKPA2
+14 ; G:$$CHKPA() POINTX
+15 IF $$CHKPA2()
GOTO POINTX
+16 ;
+17 ; Who is the patient? Find all other prescriptions for this
+18 ; patient which have status 30, and add them to the RXILIST, too
+19 ; Must also have same VISIT and same DIVISION
+20 ;
+21 NEW RA0,RA1
SET RA0=^ABSPT(IEN59,0)
SET RA1=^(1)
+22 ; preserve the top-level index!
NEW IEN59
SET IEN59=""
+23 FOR
SET IEN59=$$NEXT59(IEN59)
IF 'IEN59
QUIT
Begin DoDot:2
+24 NEW RB0,RB1
SET RB0=^ABSPT(IEN59,0)
SET RB1=^(1)
+25 ; Only bundle when you have the same:
+26 ; Patient, Visit, Division, Division Source, Insurer, Pharmacy
+27 IF $PIECE(RA0,U,6,7)'=$PIECE(RB0,U,6,7)
QUIT
+28 IF $PIECE(RA1,U,4,7)'=$PIECE(RB1,U,4,7)
QUIT
+29 ; might have been canceled, or maybe 31'd
IF $PIECE(RB0,U,2)'=30
QUIT
+30 IF $PIECE(RB0,U,2)'=STATUS30
Begin DoDot:3
+31 DO IMPOSS^ABSPOSUE("P","TI","IEN59 status "_$PIECE(RB0,U,2)_" but must be 30",,"STATUS30",$TEXT(+0))
End DoDot:3
QUIT
+32 DO SETSTAT(40)
+33 SET RXILIST(IEN59)=""
End DoDot:2
POINTX ; (reversals branch here around multi-claim packeting)
+1 ;
+2 ; so now we have a big list of prescriptions, RXILIST(*)
+3 ; they're all marked with status = 40 PACKETIZING
+4 ; Get going - packetize them!
+5 ;
+6 ;
SET ERROR=$$PACKET^ABSPOSQG
+7 ;
+8 ; Having packetized, reset status to 50, Waiting for transmit
+9 ; There should never be an error returned by $$PACKET,
+10 ; although it could happen.
+11 ; But if there was an error, reset the status to 99 right now.
+12 ; And set that status for every prescription in the RXILIST,
+13 ; even if maybe only one of them caused all the trouble.
+14 ;
+15 SET IEN59=""
FOR
SET IEN59=$ORDER(RXILIST(IEN59))
IF IEN59=""
QUIT
Begin DoDot:2
+16 IF ERROR
Begin DoDot:3
+17 ;
DO SETSTAT(99)
+18 ;
DO SETRESU($PIECE(ERROR,U),$PIECE(ERROR,U,2,$LENGTH(ERROR,U)))
End DoDot:3
+19 IF '$TEST
Begin DoDot:3
+20 ; "Waiting for transmit"
DO SETSTAT(50)
End DoDot:3
End DoDot:2
End DoDot:1
+21 DO UNLOCK59
+22 QUIT
+23 ;
+24 ; TASK^ABSPOSQ2 starts up a sender-receiver in ABSPOSQ3.
+25 ; TASK is an entry point used by POKE^ABSPOS2D
+26 ; It may well be called from other places in the future,
+27 ; if we try to be clever and start the dialing while we're getting
+28 ; claim information together, for instance.
+29 ;
TASK ;EP - ABSPOS2D,ABSPOSAP,ABSPOSC3,ABSPOSQG
+1 NEW X,Y,%DT
+2 SET X="N"
SET %DT="ST"
DO ^%DT
+3 DO TASKAT(Y)
+4 QUIT
TASKAT(ZTDTH) ;EP - ABSPOSQJ
+1 ;ZTDTH = time when you want COMMS^ABSPOSQ3 to run
+2 ; called from TASK, above, normally
+3 ; called here from ABSPOSQ3 when it's requeueing itself for
+4 ; retry after a dial-out error condition
+5 ;N (DUZ,DIALOUT,TIME,ZTDTH)
+6 NEW ZTRTN,ZTIO,ZTSAVE
+7 SET ZTRTN="COMMS^ABSPOSQ3"
SET ZTIO=""
+8 ; which entry in 9002313.55
SET ZTSAVE("DIALOUT")=""
+9 DO ^%ZTLOAD
+10 QUIT
KSCRATCH ;EP - ABSPOSQG ; Kill scratch globals
+1 KILL ^ABSPECX($JOB,"R")
+2 KILL ^ABSPECX($JOB,"C")
+3 QUIT
+4 ;
CHKPA() ;---------------------------------------------------------------
+1 ;IHS/SD/lwj 8/30/02 NCPDP 5.1 - we aren't quite ready for this
+2 ; yet - the below logic is going to work with the actual
+3 ; prior authorization segment, and no one is going to use that
+4 ; or support that segment for a while. SO.....I'm leaving this
+5 ; here for future reference - BUT for now, we're going to use
+6 ; the CHKPA2 routine to simply check for field 461 and 461.
+7 ;*
+8 ;IHS/SD/lwj 8/5/02 NCPDP 5.1 If any of the following fields
+9 ; appear as an override on this claim, we must consider it a prior
+10 ; authorization claim, and it cannot be bundled with other claims.
+11 ; 498.01 Request Type
+12 ; 498.02 Request Period Date Begin
+13 ; 498.03 Request Period Date End
+14 ; 498.04 Basis of Request
+15 ;
+16 NEW OVRREC,OVRFLD,NCPDPF,NCPDPFN,PACLM
+17 SET PACLM=0
+18 ;
+19 ;grab the overrides
SET OVRREC=$PIECE($GET(^ABSPT(IEN59,1)),U,13)
+20 ;no overrides - can't be a prior auth claim
IF OVRREC=""
QUIT 0
+21 ;
+22 ; loop through the overrides and look for the prior auth fields
+23 SET OVRFLD=0
+24 FOR
SET OVRFLD=$ORDER(^ABSP(9002313.511,OVRREC,1,OVRFLD))
IF '+OVRFLD
QUIT
Begin DoDot:1
+25 ;int fld
SET NCPDPF=$PIECE($GET(^ABSP(9002313.511,OVRREC,1,OVRFLD,0)),U)
+26 ;fld number
SET NCPDPFN=$PIECE($GET(^ABSPF(9002313.91,NCPDPF,0)),U)
+27 IF (NCPDPFN<498.01)!(NCPDPFN>498.04)
QUIT
+28 SET PACLM=1
End DoDot:1
+29 ;
+30 QUIT PACLM
+31 ;
CHKPA2() ;---------------------------------------------------------------
+1 ; IHS/SD/lwj 8/30/02 NCPDP 5.1
+2 ;Until processors are ready to use the prior authorization
+3 ; segment, we are going to use this routine to check for
+4 ; a prior authorization. To do this we will simply check
+5 ; for field 461 (Prior Authorization type code) and field
+6 ; 462 (Prior Authorization Number Submitted)
+7 ; If either exist, we will not bundle the claim. Prior
+8 ; authorization claims must be sent on their own.
+9 ;*
+10 ;
+11 NEW PATYP,PANUM
+12 SET PACLM=0
+13 ;
+14 ;prior auth type code
SET PATYP=$PIECE($GET(^ABSPT(IEN59,1)),U,15)
+15 ;prior auth number
SET PANUM=$PIECE($GET(^ABSPT(IEN59,1)),U,9)
+16 IF ($GET(PATYP)'="")!($GET(PANUM)'="")
SET PACLM=1
+17 ;
+18 QUIT PACLM
