ABSPECA9 ; IHS/FCS/DRS - pretty print pharm claim packet ;
;;1.0;PHARMACY POINT OF SALE;;JUN 21, 2001
; Development utility; not hooked into any option
; DO PRINT^ABSPECA9(record,format) ;format defaults based on Bin #
; DO PRINTN^ABSPECA9(IEN,JOB) for ^ABSPEC(job,"C",ien,n)
; (job defaults to $J)
Q
TESTING ;O 51:("TEMP.OUT":"W") U 51
D PRINTN(17636,4,1)
;C 51
Q
PRINTN(IEN,JOB,DUMP) ; print from ^ABSPEC(job,"C",ien,n)
N REC S REC=""
I $G(JOB)="" S JOB=$J
N I F I=1:1:^ABSPECX(JOB,"C",IEN,0) S REC=REC_^(I) ; reconstruct
I $G(DUMP) D
.N I,J F I=1:20:$L(REC) D
..W $J(I,4),"/ "
..F J=0:1:19 D
...I J=10 W " | "
...N X S X=$E(REC,I+J)
...I X?.ANP W "'",X," "
...E W $J($A(X),3)
..W !
.
; Find Bin number
N BIN S BIN=$E(REC,4,9)
N FMT S FMT=$$FINDFMT(BIN)
I FMT="" W "Cannot find format for Bin# ",BIN,!
D PRINT(REC,FMT)
Q
FINDFMT(BIN) ; given BIN, lookup format and return it
; This will work, but beware cases like MedImpact, where you might
; have multiple formats using the same bin. In the Medimpact case,
; the only difference between the formats is the Processor Control
; Number that is sent in the NDC packet.
;W "FINDFMT(",BIN,")",!
N STOP
N A S A="" F S A=$O(^ABSPF(9002313.92,A)) Q:A="" D Q:$G(STOP)
.N B S B=$G(^ABSPF(9002313.92,A,1)),B=$P(B,U)
.I B=BIN S STOP=1 ; found it
Q A
PRINT(REC,FMT) ; FMT pointer into ^ABSPF(9002313.92,ien) ; defaultable
; REC = the assembled record
; Caller takes care of IO device, we just write
N POS S POS=1 ; position in record
I $E(REC,1,2)="HN" D
.N X S X=$E(REC,3)
.I X="*" W "Production mode"
.E I X="." W "Test mode"
.E W "Mode ",X," unknown?"
.W !
.S POS=POS+3
N TRANCODE ; transaction code
I '$D(FMT) N FMT S FMT=$$FINDFMT($E(REC,POS,POS+5))
I '$G(FMT) W "Format unknown",! Q
N X S X=^ABSPF(9002313.92,FMT,0)
W "Format: ",$P(X,U),!
N SECTION F SECTION=10,20 D PRINT1
N TRANNUM F TRANNUM=1:1:TRANCODE F SECTION=30,40 DO PRINT1
I $L(REC)+1'=POS W "Mismatch; length of record = ",$L(REC)
I W "; +1 = ",$L(REC)+1," '= position ",POS,!
Q
NAME(X) I X=10 Q "Claim Header - Required"
I X=20 Q "Claim Header - Optional"
I X=30 Q "Claim Information "_$S(TRANCODE>1:"#"_TRANNUM_" of "_TRANCODE_")",1:"")_" - Required"
I X=40 Q "Claim Information - Optional"
W "X=",X,! ; invalid
D IMPOSS^ABSPOSUE("P","TI",X,,"NAME",$T(+0))
Q
PRINT1 ; printing one section
W " - - - ",$$NAME(SECTION)," - - - at position ",POS," - - -",!
I SECTION=30 D
.I $A(REC,POS)=29 S POS=POS+1
.E W "Expected $C(29) separator was not found",!
N FIELD,ORDER S (FIELD,ORDER)=""
F D NEXT Q:FIELD="" D PRINT2
Q
NEXT ; given SECTION and previous ORDER,
; advance ORDER and return the ncpdp FIELD number
S ORDER=$O(^ABSPF(9002313.92,FMT,SECTION,"B",ORDER))
I ORDER="" S FIELD="" Q
N IEN S IEN=$O(^ABSPF(9002313.92,FMT,SECTION,"B",ORDER,""))
I 'IEN D IMPOSS^ABSPOSUE("DB","TI",,,"NEXT",$T(+0))
N X S X=^ABSPF(9002313.92,FMT,SECTION,IEN,0) ; order^field^mode
N Y S Y=$P(X,U,2) ; ien in the field file
S FIELD=Y
Q
PRINT2 ; printing one FIELD
N Z S Z=^ABSPF(9002313.91,FIELD,0) ;Number^ID^Name^Format^Length
N NUMBER S NUMBER=$P(Z,U)
N ID S ID=$P(Z,U,2)
N NAME S NAME=$P(Z,U,3)
N ANFORMAT S ANFORMAT=$P(Z,U,4) ;N,A/N,D
N LENGTH S LENGTH=$P(Z,U,5)
W NUMBER ; NCPDP field number
I ID]"" W "-",ID
E W " "
N VALUE S VALUE=$$PICKOFF
I VALUE]"" D
.W " ",$J($P(VALUE,U),3),"-",$J($P(VALUE,U,2),3),": "
.S VALUE=$P(VALUE,U,3,$L(VALUE,U))
W " ",NAME
I VALUE]"" D
.W "="
.I VALUE?.E1" " S VALUE=$$QUOTE(VALUE)
.W VALUE
.I VALUE?.E1C.E W " (contains control character(s)!)"
E W " not present"
I NUMBER=103 S TRANCODE=VALUE
W !
Q
QUOTE(X) Q """"_X_""""
PICKOFF() ;given REC and POS within it, pick off data
; also given: field's ID and LENGTH and ANFORMAT
; Delimiter is $C(28) - pick it off too, but don't return it
I $A(REC,POS)=28,$E(REC,POS+1,POS+2)'=ID Q ""
I $A(REC,POS)=28,$E(REC,POS+1,POS+2)=ID S POS=POS+3
N FIXED S FIXED=LENGTH ; is it fixed length?
N END
I FIXED S END=POS+FIXED-1
E D
.N X F END=POS:1:POS+LENGTH-1 S X=$A(REC,END) Q:X=-1!(X=28)!(X=29)
N RET S RET=$E(REC,POS,END) ; return up to but not including delimiter
;ZW FIXED,LENGTH,POS,END,RET
;R ">>>",%,!
S RET=POS_U_END_U_RET
S POS=END+1
Q RET
ABSPECA9 ; IHS/FCS/DRS - pretty print pharm claim packet ;
+1 ;;1.0;PHARMACY POINT OF SALE;;JUN 21, 2001
+2 ; Development utility; not hooked into any option
+3 ; DO PRINT^ABSPECA9(record,format) ;format defaults based on Bin #
+4 ; DO PRINTN^ABSPECA9(IEN,JOB) for ^ABSPEC(job,"C",ien,n)
+5 ; (job defaults to $J)
+6 QUIT
TESTING ;O 51:("TEMP.OUT":"W") U 51
+1 DO PRINTN(17636,4,1)
+2 ;C 51
+3 QUIT
PRINTN(IEN,JOB,DUMP) ; print from ^ABSPEC(job,"C",ien,n)
+1 NEW REC
SET REC=""
+2 IF $GET(JOB)=""
SET JOB=$JOB
+3 ; reconstruct
NEW I
FOR I=1:1:^ABSPECX(JOB,"C",IEN,0)
SET REC=REC_^(I)
+4 IF $GET(DUMP)
Begin DoDot:1
+5 NEW I,J
FOR I=1:20:$LENGTH(REC)
Begin DoDot:2
+6 WRITE $JUSTIFY(I,4),"/ "
+7 FOR J=0:1:19
Begin DoDot:3
+8 IF J=10
WRITE " | "
+9 NEW X
SET X=$EXTRACT(REC,I+J)
+10 IF X?.ANP
WRITE "'",X," "
+11 IF '$TEST
WRITE $JUSTIFY($ASCII(X),3)
End DoDot:3
+12 WRITE !
End DoDot:2
+13 End DoDot:1
+14 ; Find Bin number
+15 NEW BIN
SET BIN=$EXTRACT(REC,4,9)
+16 NEW FMT
SET FMT=$$FINDFMT(BIN)
+17 IF FMT=""
WRITE "Cannot find format for Bin# ",BIN,!
+18 DO PRINT(REC,FMT)
+19 QUIT
FINDFMT(BIN) ; given BIN, lookup format and return it
+1 ; This will work, but beware cases like MedImpact, where you might
+2 ; have multiple formats using the same bin. In the Medimpact case,
+3 ; the only difference between the formats is the Processor Control
+4 ; Number that is sent in the NDC packet.
+5 ;W "FINDFMT(",BIN,")",!
+6 NEW STOP
+7 NEW A
SET A=""
FOR
SET A=$ORDER(^ABSPF(9002313.92,A))
IF A=""
QUIT
Begin DoDot:1
+8 NEW B
SET B=$GET(^ABSPF(9002313.92,A,1))
SET B=$PIECE(B,U)
+9 ; found it
IF B=BIN
SET STOP=1
End DoDot:1
IF $GET(STOP)
QUIT
+10 QUIT A
PRINT(REC,FMT) ; FMT pointer into ^ABSPF(9002313.92,ien) ; defaultable
+1 ; REC = the assembled record
+2 ; Caller takes care of IO device, we just write
+3 ; position in record
NEW POS
SET POS=1
+4 IF $EXTRACT(REC,1,2)="HN"
Begin DoDot:1
+5 NEW X
SET X=$EXTRACT(REC,3)
+6 IF X="*"
WRITE "Production mode"
+7 IF '$TEST
IF X="."
WRITE "Test mode"
+8 IF '$TEST
WRITE "Mode ",X," unknown?"
+9 WRITE !
+10 SET POS=POS+3
End DoDot:1
+11 ; transaction code
NEW TRANCODE
+12 IF '$DATA(FMT)
NEW FMT
SET FMT=$$FINDFMT($EXTRACT(REC,POS,POS+5))
+13 IF '$GET(FMT)
WRITE "Format unknown",!
QUIT
+14 NEW X
SET X=^ABSPF(9002313.92,FMT,0)
+15 WRITE "Format: ",$PIECE(X,U),!
+16 NEW SECTION
FOR SECTION=10,20
DO PRINT1
+17 NEW TRANNUM
FOR TRANNUM=1:1:TRANCODE
FOR SECTION=30,40
DO PRINT1
+18 IF $LENGTH(REC)+1'=POS
WRITE "Mismatch; length of record = ",$LENGTH(REC)
+19 IF $TEST
WRITE "; +1 = ",$LENGTH(REC)+1," '= position ",POS,!
+20 QUIT
NAME(X) IF X=10
QUIT "Claim Header - Required"
+1 IF X=20
QUIT "Claim Header - Optional"
+2 IF X=30
QUIT "Claim Information "_$SELECT(TRANCODE>1:"#"_TRANNUM_" of "_TRANCODE_")",1:"")_" - Required"
+3 IF X=40
QUIT "Claim Information - Optional"
+4 ; invalid
WRITE "X=",X,!
+5 DO IMPOSS^ABSPOSUE("P","TI",X,,"NAME",$TEXT(+0))
+6 QUIT
PRINT1 ; printing one section
+1 WRITE " - - - ",$$NAME(SECTION)," - - - at position ",POS," - - -",!
+2 IF SECTION=30
Begin DoDot:1
+3 IF $ASCII(REC,POS)=29
SET POS=POS+1
+4 IF '$TEST
WRITE "Expected $C(29) separator was not found",!
End DoDot:1
+5 NEW FIELD,ORDER
SET (FIELD,ORDER)=""
+6 FOR
DO NEXT
IF FIELD=""
QUIT
DO PRINT2
+7 QUIT
NEXT ; given SECTION and previous ORDER,
+1 ; advance ORDER and return the ncpdp FIELD number
+2 SET ORDER=$ORDER(^ABSPF(9002313.92,FMT,SECTION,"B",ORDER))
+3 IF ORDER=""
SET FIELD=""
QUIT
+4 NEW IEN
SET IEN=$ORDER(^ABSPF(9002313.92,FMT,SECTION,"B",ORDER,""))
+5 IF 'IEN
DO IMPOSS^ABSPOSUE("DB","TI",,,"NEXT",$TEXT(+0))
+6 ; order^field^mode
NEW X
SET X=^ABSPF(9002313.92,FMT,SECTION,IEN,0)
+7 ; ien in the field file
NEW Y
SET Y=$PIECE(X,U,2)
+8 SET FIELD=Y
+9 QUIT
PRINT2 ; printing one FIELD
+1 ;Number^ID^Name^Format^Length
NEW Z
SET Z=^ABSPF(9002313.91,FIELD,0)
+2 NEW NUMBER
SET NUMBER=$PIECE(Z,U)
+3 NEW ID
SET ID=$PIECE(Z,U,2)
+4 NEW NAME
SET NAME=$PIECE(Z,U,3)
+5 ;N,A/N,D
NEW ANFORMAT
SET ANFORMAT=$PIECE(Z,U,4)
+6 NEW LENGTH
SET LENGTH=$PIECE(Z,U,5)
+7 ; NCPDP field number
WRITE NUMBER
+8 IF ID]""
WRITE "-",ID
+9 IF '$TEST
WRITE " "
+10 NEW VALUE
SET VALUE=$$PICKOFF
+11 IF VALUE]""
Begin DoDot:1
+12 WRITE " ",$JUSTIFY($PIECE(VALUE,U),3),"-",$JUSTIFY($PIECE(VALUE,U,2),3),": "
+13 SET VALUE=$PIECE(VALUE,U,3,$LENGTH(VALUE,U))
End DoDot:1
+14 WRITE " ",NAME
+15 IF VALUE]""
Begin DoDot:1
+16 WRITE "="
+17 IF VALUE?.E1" "
SET VALUE=$$QUOTE(VALUE)
+18 WRITE VALUE
+19 IF VALUE?.E1C.E
WRITE " (contains control character(s)!)"
End DoDot:1
+20 IF '$TEST
WRITE " not present"
+21 IF NUMBER=103
SET TRANCODE=VALUE
+22 WRITE !
+23 QUIT
QUOTE(X) QUIT """"_X_""""
PICKOFF() ;given REC and POS within it, pick off data
+1 ; also given: field's ID and LENGTH and ANFORMAT
+2 ; Delimiter is $C(28) - pick it off too, but don't return it
+3 IF $ASCII(REC,POS)=28
IF $EXTRACT(REC,POS+1,POS+2)'=ID
QUIT ""
+4 IF $ASCII(REC,POS)=28
IF $EXTRACT(REC,POS+1,POS+2)=ID
SET POS=POS+3
+5 ; is it fixed length?
NEW FIXED
SET FIXED=LENGTH
+6 NEW END
+7 IF FIXED
SET END=POS+FIXED-1
+8 IF '$TEST
Begin DoDot:1
+9 NEW X
FOR END=POS:1:POS+LENGTH-1
SET X=$ASCII(REC,END)
IF X=-1!(X=28)!(X=29)
QUIT
End DoDot:1
+10 ; return up to but not including delimiter
NEW RET
SET RET=$EXTRACT(REC,POS,END)
+11 ;ZW FIXED,LENGTH,POS,END,RET
+12 ;R ">>>",%,!
+13 SET RET=POS_U_END_U_RET
+14 SET POS=END+1
+15 QUIT RET
