ABSPOSSH.m

ABSPOSSH ; IHS/SD/RLT - Special sets for formats - cont;      [ 7/11/2007  9:40 AM ]

 ;;1.0;PHARMACY POINT OF SALE;**23,29,39**;JUL 11, 2007;Build 38

 ;---

 ; New diagnosis code fields in clinical segment.

 ; Set logic for flds 491, 492 and 424 in this routine to 

 ; avoid the wrapping within the global which has been known to 

 ; split when installed on certain systems.

 ;---

FLD491 ;DIAGNOSIS CODE COUNT - called from set logic in ABSP NCPDP Field

 ;

 S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),490),U)=ABSP("X")

 ;

 Q

 ;

FLD492 ;DIAGNOSIS CODE QUALIFIER - called from set logic in ABSP NCPDP Field

 ;

 Q:$G(DIAG)=""  ;IHS/OIT/SCR 2/13/09 patch 29

 S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),491.01,DIAG,0),U,2)=ABSP("X")

 ;

 Q

 ;

FLD424 ;DIAGNOSIS CODE - called from set logic in ABSP NCPDP Field

 ;

 Q:$G(DIAG)=""  ;IHS/OIT/SCR 2/13/09 patch 29

 S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),491.01,DIAG,0),U,3)=ABSP("X")

 ;

 Q

 ;IHS/CNI/SCR 031710 patch 39 START CHANGES

 ;called from set logic in ABSP NCPDP Field Defs repeating field in the COB/Other Payments 5.1 Segment

FLD337 ; COB/Other Paymnts Count

 S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),330),U,7)=ABSP("X")

 S ^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),337,0)="^9002313.0401A^^"_ABSP("X")

 Q

FLD338 ; Other Payer Coverage Type

 Q:'$G(ABSPCOB)

 S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),337,ABSPCOB,0),U,2)=ABSP("X")

 Q

FLD339 ; Other Payer ID Qualifier

 Q:'$G(ABSPCOB)

 S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),337,ABSPCOB,0),U,3)=ABSP("X")

 Q

FLD340 ; Other Payer ID

 Q:'$G(ABSPCOB)

 S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),337,ABSPCOB,0),U,4)=ABSP("X")

 Q

FLD341 ; Other Amt Paid Cnt

 Q:'$G(ABSPCOB)

 S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),337,ABSPCOB,0),U,6)=ABSP("X")

 Q

FLD342 ; Other Payer Amt Paid Qual

 Q:'$G(COB)

 Q:$G(AMT)=""

 S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),337,ABSPCOB,1,AMT,0),U,2)=ABSP("X")

 Q

FLD431 ; OTHER PAYOR AMOUNT

 Q:'$G(ABSPCOB)

 Q:$G(AMT)=""

 S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),337,ABSPCOB,1,AMT,0),U,3)=ABSP("X")

 Q

FLD443 ; OTHER PAYOR DATE

 Q:'$G(ABSPCOB)

 S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),337,ABSPCOB,0),U,5)=ABSP("X")

 Q

FLD471 ; Other Payer Reject Count

 Q:'$G(COB)

 Q:$G(AMT)=""

 S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),337,COB,0),U,7)=ABSP("X")

 Q

FLD472 ; Other Payer Reject Code

 Q:'$G(COB)

 Q:$G(REJ)=""

 S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),337,COB,2,REJ,0),U,2)=ABSP("X")

 Q

 ;IHS/CNI/SCR 031710 patch 39 END CHANGES

ABSPOSSH  ; IHS/SD/RLT - Special sets for formats - cont;      [ 7/11/2007  9:40 AM ]

 +1       ;;1.0;PHARMACY POINT OF SALE;**23,29,39**;JUL 11, 2007;Build 38

 +2       ;---

 +3       ; New diagnosis code fields in clinical segment.

 +4       ; Set logic for flds 491, 492 and 424 in this routine to 

 +5       ; avoid the wrapping within the global which has been known to 

 +6       ; split when installed on certain systems.

 +7       ;---

FLD491    ;DIAGNOSIS CODE COUNT - called from set logic in ABSP NCPDP Field

 +1       ;

 +2        SET $PIECE(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),490),U)=ABSP("X")

 +3       ;

 +4        QUIT 

 +5       ;

FLD492    ;DIAGNOSIS CODE QUALIFIER - called from set logic in ABSP NCPDP Field

 +1       ;

 +2       ;IHS/OIT/SCR 2/13/09 patch 29

           IF $GET(DIAG)=""

               QUIT 

 +3        SET $PIECE(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),491.01,DIAG,0),U,2)=ABSP("X")

 +4       ;

 +5        QUIT 

 +6       ;

FLD424    ;DIAGNOSIS CODE - called from set logic in ABSP NCPDP Field

 +1       ;

 +2       ;IHS/OIT/SCR 2/13/09 patch 29

           IF $GET(DIAG)=""

               QUIT 

 +3        SET $PIECE(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),491.01,DIAG,0),U,3)=ABSP("X")

 +4       ;

 +5        QUIT 

 +6       ;IHS/CNI/SCR 031710 patch 39 START CHANGES

 +7       ;called from set logic in ABSP NCPDP Field Defs repeating field in the COB/Other Payments 5.1 Segment

FLD337    ; COB/Other Paymnts Count

 +1        SET $PIECE(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),330),U,7)=ABSP("X")

 +2        SET ^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),337,0)="^9002313.0401A^^"_ABSP("X")

 +3        QUIT 

FLD338    ; Other Payer Coverage Type

 +1        IF '$GET(ABSPCOB)

               QUIT 

 +2        SET $PIECE(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),337,ABSPCOB,0),U,2)=ABSP("X")

 +3        QUIT 

FLD339    ; Other Payer ID Qualifier

 +1        IF '$GET(ABSPCOB)

               QUIT 

 +2        SET $PIECE(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),337,ABSPCOB,0),U,3)=ABSP("X")

 +3        QUIT 

FLD340    ; Other Payer ID

 +1        IF '$GET(ABSPCOB)

               QUIT 

 +2        SET $PIECE(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),337,ABSPCOB,0),U,4)=ABSP("X")

 +3        QUIT 

FLD341    ; Other Amt Paid Cnt

 +1        IF '$GET(ABSPCOB)

               QUIT 

 +2        SET $PIECE(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),337,ABSPCOB,0),U,6)=ABSP("X")

 +3        QUIT 

FLD342    ; Other Payer Amt Paid Qual

 +1        IF '$GET(COB)

               QUIT 

 +2        IF $GET(AMT)=""

               QUIT 

 +3        SET $PIECE(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),337,ABSPCOB,1,AMT,0),U,2)=ABSP("X")

 +4        QUIT 

FLD431    ; OTHER PAYOR AMOUNT

 +1        IF '$GET(ABSPCOB)

               QUIT 

 +2        IF $GET(AMT)=""

               QUIT 

 +3        SET $PIECE(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),337,ABSPCOB,1,AMT,0),U,3)=ABSP("X")

 +4        QUIT 

FLD443    ; OTHER PAYOR DATE

 +1        IF '$GET(ABSPCOB)

               QUIT 

 +2        SET $PIECE(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),337,ABSPCOB,0),U,5)=ABSP("X")

 +3        QUIT 

FLD471    ; Other Payer Reject Count

 +1        IF '$GET(COB)

               QUIT 

 +2        IF $GET(AMT)=""

               QUIT 

 +3        SET $PIECE(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),337,COB,0),U,7)=ABSP("X")

 +4        QUIT 

FLD472    ; Other Payer Reject Code

 +1        IF '$GET(COB)

               QUIT 

 +2        IF $GET(REJ)=""

               QUIT 

 +3        SET $PIECE(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),337,COB,2,REJ,0),U,2)=ABSP("X")

 +4        QUIT 

 +5       ;IHS/CNI/SCR 031710 patch 39 END CHANGES