- 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