Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ABSPECA9

ABSPECA9.m

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