- ABSPICNV ; IHS/OIT/CASSevern/Pieran ran 2/24/2011 - Convert Insurance Profiles based on Formats
- ;;1.0;PHARMACY POINT OF SALE;**D.0,48**;JUN 21, 2001;Build 38
- ;
- ; This routine will go through each ABSP Insurer entry and get the information off the corresponding Format and populate the necessary entries in the insurer file
- EN ;EP
- N ABSPINS,ABSPFMT
- I $D(^ABSP(9002313.99,1,"ABSPICNV")) Q ;TESTING ONLY => D REVERSE ;This conversion program has already been run...reverse it before running again
- S ABSPINS=0
- F S ABSPINS=$O(^ABSPEI(ABSPINS)) Q:ABSPINS="" D
- . S ABSPFMT=$P($G(^ABSPEI(ABSPINS,100)),U)
- . Q:'ABSPFMT
- . D PROCESS(ABSPINS,ABSPFMT)
- S ^ABSP(9002313.99,1,"ABSPICNV")=1 ;This is how we know if this conversion has been run or not.
- Q
- PROCESS(ABSPINS,ABSPFMT) ;Process the format here
- N ABSPBIN,ABSPPCN,ABSPMPD,ABSPVER,ABSPMAX,ABSPDISP,ABSPCONT,ABSPEXCL,ABSPHELP,ABSPSPEC,ABSPSPSG,ABSPSPFL
- D GETINFO(ABSPFMT)
- D POPTOP(ABSPINS,ABSPBIN,ABSPPCN,ABSPMPD,ABSPVER,ABSPMAX,ABSPDISP,ABSPCONT,ABSPEXCL,ABSPHELP)
- D POPSPEC(ABSPINS,.ABSPSPEC)
- D POPSEG(ABSPINS,.ABSPSPSG)
- D POPFLD(ABSPINS,.ABSPSPFL)
- Q
- GETINFO(ABSPFMT)
- N ABSPFARY,ABSPINCL,ABSPSUPP
- D GETS^DIQ(9002313.92,ABSPFMT_",","**","","ABSPFARY")
- S ABSPBIN=ABSPFARY(9002313.92,ABSPFMT_",",1.01)
- S ABSPPCN=ABSPFARY(9002313.92,ABSPFMT_",",1.3)
- S ABSPVER=5.1
- S ABSPHELP=ABSPFARY(9002313.92,ABSPFMT_",",1.05)
- S ABSPMPD=ABSPFARY(9002313.92,ABSPFMT_",",1.2)
- S:ABSPMPD="" ABSPMPD="N"
- S ABSPMAX=ABSPFARY(9002313.92,ABSPFMT_",",1.03)
- S ABSPDISP=ABSPFARY(9002313.92,ABSPFMT_",",1.08)
- S ABSPCONT=ABSPFARY(9002313.92,ABSPFMT_",",1.09)
- S ABSPEXCL=ABSPFARY(9002313.92,ABSPFMT_",",1.1)
- D GETSUPSEGS(.ABSPFARY,.ABSPSPSG)
- D GETSPEFLDS(.ABSPFARY,.ABSPSPEC)
- D GETSUPFLDS(.ABSPFARY,.ABSPSPSG,.ABSPSPFL)
- Q
- GETINCFLDS(ABSPFARY,ABSPINCL) ;Get list of all fields included on this format
- N ARR
- S ARR="ABSPFARY(9002313.9205)"
- F S ARR=$Q(@ARR) Q:ARR'["ABSPFARY(9002313" S:($QS(ARR,3)=.02)&&(@ARR'="") ABSPINCL(@ARR)=""
- Q
- GETSPEFLDS(ABSPFARY,ABSPSPEC) ;Get list of all fields requiring special coding
- N ARR
- S ARR="ABSPFARY(9002313.9205)"
- F S ARR=$Q(@ARR) Q:ARR'["ABSPFARY(9002313" D:($QS(ARR,3)=.03)&&(@ARR="SPECIAL")
- . N LINE,X,Y
- . S LINE=0
- . F S LINE=$O(ABSPFARY($QS(ARR,1),$QS(ARR,2),1,LINE)) Q:LINE="" D
- . . S X=ABSPFARY($QS(ARR,1),$QS(ARR,2),1,LINE),X=$P(X,";") F S Y=$E(X,$L(X)) Q:Y'=" " S X=$E(X,1,$L(X)-1)
- . . I LINE=1 S ABSPSPEC(ABSPFARY($QS(ARR,1),$QS(ARR,2),.02))=X
- . . ELSE S ABSPSPEC(ABSPFARY($QS(ARR,1),$QS(ARR,2),.02))=ABSPSPEC(ABSPFARY($QS(ARR,1),$QS(ARR,2),.02))_" "_X
- Q
- GETSUPSEGS(ABSPFARY,ABSPSPSG) ;Get list of all Segments to be suppressed
- I '$D(ABSPFARY(9002313.9209)) S ABSPSPSG(2)="" ;Suppress Provider Segment
- I '$D(ABSPFARY(9002313.9213)) S ABSPSPSG(5)="" ;Suppress COB Segment
- I '$D(ABSPFARY(9002313.9214)) S ABSPSPSG(6)="" ;Suppress Workers Comp Segment
- I '$D(ABSPFARY(9002313.9215)) S ABSPSPSG(8)="" ;Suppress DURR/PPS Segment
- I '$D(ABSPFARY(9002313.9217)) S ABSPSPSG(9)="" ;Suppress Coupon Segment
- I '$D(ABSPFARY(9002313.9218)) S ABSPSPSG(10)="" ;Suppress Compound Segment
- I '$D(ABSPFARY(9002313.9219)) S ABSPSPSG(12)="" ;Suppress Prior Auth Segment
- I '$D(ABSPFARY(9002313.922)) S ABSPSPSG(13)="" ;Suppress Clinical Segment
- ;Since these are new segments in D.0 We'll have to suppress them all for now
- S ABSPSPSG(14)="" ;Suppress Additional Doc Segment
- S ABSPSPSG(15)="" ;Suppress Facility Segment
- S ABSPSPSG(16)="" ;Suppress Narrative Segment
- Q
- GETSUPFLDS(ABSPFARY,ABSPSPSG,ABSPSPFL) ;Get list of all fields to be suppressed
- N FLDARR,FLDNUM,NCPDPFLD,ABSPINCL,SEG,SEGMENT,SEGFLDS
- S SEG("CLAIM")="455^402^436^407^456^457^458^459^415^419^354^420^460^308^429^453^445^446^330^454^600^418^461^462^463^464^343^344^345^357^391^995^996^147^114"
- S SEG("PATIENT")="331^332^310^322^323^324^325^326^307^333^334^335^350^384"
- S SEG("INSURANCE")="302^312^313^314^524^309^301^303^306^359^360^361^997^115^116"
- S SEG("PRESCRIBER")="466^411^467^427^498^468^421^469^470^364^365^366^367^368"
- S SEG("PRICING")="433^438^478^479^480^481^482^483^484^426^423^113"
- S SEG("COB")="337^338^339^340^443^993^341^342^431^471^472^353^351^352^392^393^394"
- S SEG("WORKCOMP")="434^315^316^317^318^319^320^321^327^435^117^118^119^120^121^122^123^124^125^126"
- S SEG("DURRPPS")="473^439^440^441^474^475^476"
- S SEG("COUPON")="485^486^487"
- S SEG("COMPOUND")="450^451^452^447^488^489^448^449^490^362^363"
- S SEG("CLINICAL")="491^492^424^493^494^495^496^497^499"
- S SEG("PRIORAUTH")="498.01^498.02^498.03^498.04^498.05^498.06^498.07^498.08^498.09^498.11^498.13^498.14^503"
- S SEG("PROVIDER")="465^444"
- ;No reason to do these...they are new to D.0 and won't exist on ANY Format.
- ;S SEG("ADDOC")="369^374^375^373^371^370^372^376^377^378^379^380^381^382^383"
- ;S SEG("FACILITY")="336^385^386^388^387^389"
- ;S SEG("NARRATIVE")="390"
- ;First set up an array of all NCPDP FIELDS currently on this format
- D GETINCFLDS(.ABSPFARY,.ABSPINCL)
- ;Now go through the list of all possible fields and suppress any that aren't on the format currently and aren't on an already suppressed SEGMENT
- S SEGMENT=""
- F S SEGMENT=$O(SEG(SEGMENT)) Q:SEGMENT="" D
- . S SEGFLDS=SEG(SEGMENT)
- . F I=1:1:$L(SEGFLDS,"^") D
- . . S NCPDPFLD=$P(SEGFLDS,"^",I)
- . . ;B:NCPDPFLD=301
- . . ;These Segments are all mandatory...and therefore can't be suppressed
- . . I "^CLAIM^PATIENT^INSURANCE^PRESCRIBER^PRICING^"[("^"_SEGMENT_"^") D
- . . . I '$D(ABSPINCL(NCPDPFLD)) S ABSPSPFL(NCPDPFLD)=""
- . . ;If the Segment is already suppressed don't waste time and disk space suppressing the individual field
- . . ELSE D
- . . . I ('$D(ABSPINCL(NCPDPFLD)))&&(SEGMENT="COB")&&('$D(ABSPSPSG(5))) S ABSPSPFL(NCPDPFLD)=""
- . . . I ('$D(ABSPINCL(NCPDPFLD)))&&(SEGMENT="WORKCOMP")&&('$D(ABSPSPSG(6))) S ABSPSPFL(NCPDPFLD)=""
- . . . I ('$D(ABSPINCL(NCPDPFLD)))&&(SEGMENT="DURRPPS")&&('$D(ABSPSPSG(8))) S ABSPSPFL(NCPDPFLD)=""
- . . . I ('$D(ABSPINCL(NCPDPFLD)))&&(SEGMENT="COUPON")&&('$D(ABSPSPSG(9))) S ABSPSPFL(NCPDPFLD)=""
- . . . I ('$D(ABSPINCL(NCPDPFLD)))&&(SEGMENT="COMPOUND")&&('$D(ABSPSPSG(10))) S ABSPSPFL(NCPDPFLD)=""
- . . . I ('$D(ABSPINCL(NCPDPFLD)))&&(SEGMENT="CLINICAL")&&('$D(ABSPSPSG(5))) S ABSPSPFL(NCPDPFLD)=""
- . . . I ('$D(ABSPINCL(NCPDPFLD)))&&(SEGMENT="PRIORAUTH")&&('$D(ABSPSPSG(12))) S ABSPSPFL(NCPDPFLD)=""
- . . . I ('$D(ABSPINCL(NCPDPFLD)))&&(SEGMENT="PROVIDER")&&('$D(ABSPSPSG(2))) S ABSPSPFL(NCPDPFLD)=""
- Q
- POPTOP(ABSPINS,ABSPBIN,ABSPPCN,ABSPMPD,ABSPVER,ABSPMAX,ABSPDISP,ABSPCONT,ABSPEXCL,ABSPHELP) ;Populate things that go on top level of Insurance
- N INS,CURHELP,ZERR ; /IHS/OIT/RAM ; 9 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
- S CURHELP=$$GET1^DIQ(9002313.4,ABSPINS_",",100.05)
- I CURHELP="" S INS(1,9002313.4,ABSPINS_",",100.05)=ABSPHELP ;Don't over-write if they already have this field on the Insurer
- S INS(1,9002313.4,ABSPINS_",",100.15)=ABSPVER
- S INS(1,9002313.4,ABSPINS_",",100.16)=ABSPBIN
- S INS(1,9002313.4,ABSPINS_",",100.17)=ABSPPCN
- S INS(1,9002313.4,ABSPINS_",",100.18)=ABSPMPD
- S INS(1,9002313.4,ABSPINS_",",100.19)=ABSPMAX
- S INS(1,9002313.4,ABSPINS_",",100.2)=ABSPDISP
- S INS(1,9002313.4,ABSPINS_",",100.3)=ABSPCONT
- S INS(1,9002313.4,ABSPINS_",",100.4)=ABSPEXCL
- ; D UPDATE^DIE("E","INS(1)")
- D UPDATE^DIE("E","INS(1)",,"ZERR") ; /IHS/OIT/RAM ; 9 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
- I $D(ZERR) D LOG^ABSPOSL2("POPTOP^ABSPICNV",.ZERR) ; /IHS/OIT/RAM ; 9 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
- Q
- POPSPEC(ABSPINS,ABSPSPEC) ;Now populate the Special Code stuff
- N NCPDPCD,INS,STRING,ZERR ; /IHS/OIT/RAM ; 9 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
- S NCPDPCD=""
- F S NCPDPCD=$O(ABSPSPEC(NCPDPCD)) Q:NCPDPCD="" D
- . Q:(NCPDPCD=111)!(NCPDPCD=103) ;These are the fields that can't be overriden
- . S STRING=$TR(ABSPSPEC(NCPDPCD),"^","|") ;Fileman won't store this string with a ^ (caret) in it
- . S INS(1,9002313.42,"+1,"_ABSPINS_",",.01)=NCPDPCD
- . S INS(1,9002313.42,"+1,"_ABSPINS_",",.02)=STRING
- . ; D UPDATE^DIE("E","INS(1)")
- . D UPDATE^DIE("E","INS(1)",,"ZERR") ; /IHS/OIT/RAM ; 9 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
- . I $D(ZERR) D LOG^ABSPOSL2("POPSPEC^ABSPICNV",.ZERR) ; /IHS/OIT/RAM ; 9 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
- Q
- POPSEG(ABSPINS,ABSPSPSG) ;Next we populate the suppressed segments
- N SEGCD,INS,ZERR ; /IHS/OIT/RAM ; 9 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
- S SEGCD=""
- F S SEGCD=$O(ABSPSPSG(SEGCD)) Q:SEGCD="" D
- . S INS(1,9002313.48,"+1,"_ABSPINS_",",.01)=SEGCD
- . ; D UPDATE^DIE("","INS(1)") ;On this one we are using the Internal value
- . D UPDATE^DIE("","INS(1)",,"ZERR") ; /IHS/OIT/RAM ; 9 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
- . I $D(ZERR) D LOG^ABSPOSL2("POPSEG^ABSPICNV",.ZERR) ; /IHS/OIT/RAM ; 9 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
- Q
- POPFLD(ABSPINS,ABSPSPFL) ;Next we populate the suppressed fields
- N NCPDPCD,ZERR ; /IHS/OIT/RAM ; 9 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
- S NCPDPCD=""
- F S NCPDPCD=$O(ABSPSPFL(NCPDPCD)) Q:NCPDPCD="" D
- . S INS(1,9002313.46,"+1,"_ABSPINS_",",.01)=NCPDPCD
- . ; D UPDATE^DIE("E","INS(1)")
- . D UPDATE^DIE("E","INS(1)",,"ZERR") ; /IHS/OIT/RAM ; 9 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
- . I $D(ZERR) D LOG^ABSPOSL2("POPFLD^ABSPICNV",.ZERR) ; /IHS/OIT/RAM ; 9 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
- Q
- REVERSE
- N ABSPINS,ABSPFMT
- S ABSPINS=0
- F S ABSPINS=$O(^ABSPEI(ABSPINS)) Q:ABSPINS="" D
- . S ABSPFMT=$P($G(^ABSPEI(ABSPINS,100)),U)
- . Q:'ABSPFMT
- . K ^ABSPEI(ABSPINS,210)
- . K ^ABSPEI(ABSPINS,220)
- . K ^ABSPEI(ABSPINS,221)
- S ^ABSP(9002313.99,1,"ABSPICNV")=0 ;This is how we know if this conversion has been run or not.
- Q
- ABSPICNV ; IHS/OIT/CASSevern/Pieran ran 2/24/2011 - Convert Insurance Profiles based on Formats
- +1 ;;1.0;PHARMACY POINT OF SALE;**D.0,48**;JUN 21, 2001;Build 38
- +2 ;
- +3 ; This routine will go through each ABSP Insurer entry and get the information off the corresponding Format and populate the necessary entries in the insurer file
- EN ;EP
- +1 NEW ABSPINS,ABSPFMT
- +2 ;TESTING ONLY => D REVERSE ;This conversion program has already been run...reverse it before running again
- IF $DATA(^ABSP(9002313.99,1,"ABSPICNV"))
- QUIT
- +3 SET ABSPINS=0
- +4 FOR
- SET ABSPINS=$ORDER(^ABSPEI(ABSPINS))
- IF ABSPINS=""
- QUIT
- Begin DoDot:1
- +5 SET ABSPFMT=$PIECE($GET(^ABSPEI(ABSPINS,100)),U)
- +6 IF 'ABSPFMT
- QUIT
- +7 DO PROCESS(ABSPINS,ABSPFMT)
- End DoDot:1
- +8 ;This is how we know if this conversion has been run or not.
- SET ^ABSP(9002313.99,1,"ABSPICNV")=1
- +9 QUIT
- PROCESS(ABSPINS,ABSPFMT) ;Process the format here
- +1 NEW ABSPBIN,ABSPPCN,ABSPMPD,ABSPVER,ABSPMAX,ABSPDISP,ABSPCONT,ABSPEXCL,ABSPHELP,ABSPSPEC,ABSPSPSG,ABSPSPFL
- +2 DO GETINFO(ABSPFMT)
- +3 DO POPTOP(ABSPINS,ABSPBIN,ABSPPCN,ABSPMPD,ABSPVER,ABSPMAX,ABSPDISP,ABSPCONT,ABSPEXCL,ABSPHELP)
- +4 DO POPSPEC(ABSPINS,.ABSPSPEC)
- +5 DO POPSEG(ABSPINS,.ABSPSPSG)
- +6 DO POPFLD(ABSPINS,.ABSPSPFL)
- +7 QUIT
- GETINFO(ABSPFMT) +1 NEW ABSPFARY,ABSPINCL,ABSPSUPP
- +2 DO GETS^DIQ(9002313.92,ABSPFMT_",","**","","ABSPFARY")
- +3 SET ABSPBIN=ABSPFARY(9002313.92,ABSPFMT_",",1.01)
- +4 SET ABSPPCN=ABSPFARY(9002313.92,ABSPFMT_",",1.3)
- +5 SET ABSPVER=5.1
- +6 SET ABSPHELP=ABSPFARY(9002313.92,ABSPFMT_",",1.05)
- +7 SET ABSPMPD=ABSPFARY(9002313.92,ABSPFMT_",",1.2)
- +8 IF ABSPMPD=""
- SET ABSPMPD="N"
- +9 SET ABSPMAX=ABSPFARY(9002313.92,ABSPFMT_",",1.03)
- +10 SET ABSPDISP=ABSPFARY(9002313.92,ABSPFMT_",",1.08)
- +11 SET ABSPCONT=ABSPFARY(9002313.92,ABSPFMT_",",1.09)
- +12 SET ABSPEXCL=ABSPFARY(9002313.92,ABSPFMT_",",1.1)
- +13 DO GETSUPSEGS(.ABSPFARY,.ABSPSPSG)
- +14 DO GETSPEFLDS(.ABSPFARY,.ABSPSPEC)
- +15 DO GETSUPFLDS(.ABSPFARY,.ABSPSPSG,.ABSPSPFL)
- +16 QUIT
- GETINCFLDS(ABSPFARY,ABSPINCL) ;Get list of all fields included on this format
- +1 NEW ARR
- +2 SET ARR="ABSPFARY(9002313.9205)"
- +3 FOR
- SET ARR=$QUERY(@ARR)
- IF ARR'["ABSPFARY(9002313"
- QUIT
- IF ($QSUBSCRIPT(ARR,3)=.02)&&(@ARR'="")
- SET ABSPINCL(@ARR)=""
- +4 QUIT
- GETSPEFLDS(ABSPFARY,ABSPSPEC) ;Get list of all fields requiring special coding
- +1 NEW ARR
- +2 SET ARR="ABSPFARY(9002313.9205)"
- +3 FOR
- SET ARR=$QUERY(@ARR)
- IF ARR'["ABSPFARY(9002313"
- QUIT
- IF ($QSUBSCRIPT(ARR,3)=.03)&&(@ARR="SPECIAL")
- Begin DoDot:1
- +4 NEW LINE,X,Y
- +5 SET LINE=0
- +6 FOR
- SET LINE=$ORDER(ABSPFARY($QSUBSCRIPT(ARR,1),$QSUBSCRIPT(ARR,2),1,LINE))
- IF LINE=""
- QUIT
- Begin DoDot:2
- +7 SET X=ABSPFARY($QSUBSCRIPT(ARR,1),$QSUBSCRIPT(ARR,2),1,LINE)
- SET X=$PIECE(X,";")
- FOR
- SET Y=$EXTRACT(X,$LENGTH(X))
- IF Y'=" "
- QUIT
- SET X=$EXTRACT(X,1,$LENGTH(X)-1)
- +8 IF LINE=1
- SET ABSPSPEC(ABSPFARY($QSUBSCRIPT(ARR,1),$QSUBSCRIPT(ARR,2),.02))=X
- +9 IF '$TEST
- SET ABSPSPEC(ABSPFARY($QSUBSCRIPT(ARR,1),$QSUBSCRIPT(ARR,2),.02))=ABSPSPEC(ABSPFARY($QSUBSCRIPT(ARR,1),$QSUBSCRIPT(ARR,2),.02))_" "_X
- End DoDot:2
- End DoDot:1
- +10 QUIT
- GETSUPSEGS(ABSPFARY,ABSPSPSG) ;Get list of all Segments to be suppressed
- +1 ;Suppress Provider Segment
- IF '$DATA(ABSPFARY(9002313.9209))
- SET ABSPSPSG(2)=""
- +2 ;Suppress COB Segment
- IF '$DATA(ABSPFARY(9002313.9213))
- SET ABSPSPSG(5)=""
- +3 ;Suppress Workers Comp Segment
- IF '$DATA(ABSPFARY(9002313.9214))
- SET ABSPSPSG(6)=""
- +4 ;Suppress DURR/PPS Segment
- IF '$DATA(ABSPFARY(9002313.9215))
- SET ABSPSPSG(8)=""
- +5 ;Suppress Coupon Segment
- IF '$DATA(ABSPFARY(9002313.9217))
- SET ABSPSPSG(9)=""
- +6 ;Suppress Compound Segment
- IF '$DATA(ABSPFARY(9002313.9218))
- SET ABSPSPSG(10)=""
- +7 ;Suppress Prior Auth Segment
- IF '$DATA(ABSPFARY(9002313.9219))
- SET ABSPSPSG(12)=""
- +8 ;Suppress Clinical Segment
- IF '$DATA(ABSPFARY(9002313.922))
- SET ABSPSPSG(13)=""
- +9 ;Since these are new segments in D.0 We'll have to suppress them all for now
- +10 ;Suppress Additional Doc Segment
- SET ABSPSPSG(14)=""
- +11 ;Suppress Facility Segment
- SET ABSPSPSG(15)=""
- +12 ;Suppress Narrative Segment
- SET ABSPSPSG(16)=""
- +13 QUIT
- GETSUPFLDS(ABSPFARY,ABSPSPSG,ABSPSPFL) ;Get list of all fields to be suppressed
- +1 NEW FLDARR,FLDNUM,NCPDPFLD,ABSPINCL,SEG,SEGMENT,SEGFLDS
- +2 SET SEG("CLAIM")="455^402^436^407^456^457^458^459^415^419^354^420^460^308^429^453^445^446^330^454^600^418^461^462^463^464^343^344^345^357^391^995^996^147^114"
- +3 SET SEG("PATIENT")="331^332^310^322^323^324^325^326^307^333^334^335^350^384"
- +4 SET SEG("INSURANCE")="302^312^313^314^524^309^301^303^306^359^360^361^997^115^116"
- +5 SET SEG("PRESCRIBER")="466^411^467^427^498^468^421^469^470^364^365^366^367^368"
- +6 SET SEG("PRICING")="433^438^478^479^480^481^482^483^484^426^423^113"
- +7 SET SEG("COB")="337^338^339^340^443^993^341^342^431^471^472^353^351^352^392^393^394"
- +8 SET SEG("WORKCOMP")="434^315^316^317^318^319^320^321^327^435^117^118^119^120^121^122^123^124^125^126"
- +9 SET SEG("DURRPPS")="473^439^440^441^474^475^476"
- +10 SET SEG("COUPON")="485^486^487"
- +11 SET SEG("COMPOUND")="450^451^452^447^488^489^448^449^490^362^363"
- +12 SET SEG("CLINICAL")="491^492^424^493^494^495^496^497^499"
- +13 SET SEG("PRIORAUTH")="498.01^498.02^498.03^498.04^498.05^498.06^498.07^498.08^498.09^498.11^498.13^498.14^503"
- +14 SET SEG("PROVIDER")="465^444"
- +15 ;No reason to do these...they are new to D.0 and won't exist on ANY Format.
- +16 ;S SEG("ADDOC")="369^374^375^373^371^370^372^376^377^378^379^380^381^382^383"
- +17 ;S SEG("FACILITY")="336^385^386^388^387^389"
- +18 ;S SEG("NARRATIVE")="390"
- +19 ;First set up an array of all NCPDP FIELDS currently on this format
- +20 DO GETINCFLDS(.ABSPFARY,.ABSPINCL)
- +21 ;Now go through the list of all possible fields and suppress any that aren't on the format currently and aren't on an already suppressed SEGMENT
- +22 SET SEGMENT=""
- +23 FOR
- SET SEGMENT=$ORDER(SEG(SEGMENT))
- IF SEGMENT=""
- QUIT
- Begin DoDot:1
- +24 SET SEGFLDS=SEG(SEGMENT)
- +25 FOR I=1:1:$LENGTH(SEGFLDS,"^")
- Begin DoDot:2
- +26 SET NCPDPFLD=$PIECE(SEGFLDS,"^",I)
- +27 ;B:NCPDPFLD=301
- +28 ;These Segments are all mandatory...and therefore can't be suppressed
- +29 IF "^CLAIM^PATIENT^INSURANCE^PRESCRIBER^PRICING^"[("^"_SEGMENT_"^")
- Begin DoDot:3
- +30 IF '$DATA(ABSPINCL(NCPDPFLD))
- SET ABSPSPFL(NCPDPFLD)=""
- End DoDot:3
- +31 ;If the Segment is already suppressed don't waste time and disk space suppressing the individual field
- +32 IF '$TEST
- Begin DoDot:3
- +33 IF ('$DATA(ABSPINCL(NCPDPFLD)))&&(SEGMENT="COB")&&('$DATA(ABSPSPSG(5)))
- SET ABSPSPFL(NCPDPFLD)=""
- +34 IF ('$DATA(ABSPINCL(NCPDPFLD)))&&(SEGMENT="WORKCOMP")&&('$DATA(ABSPSPSG(6)))
- SET ABSPSPFL(NCPDPFLD)=""
- +35 IF ('$DATA(ABSPINCL(NCPDPFLD)))&&(SEGMENT="DURRPPS")&&('$DATA(ABSPSPSG(8)))
- SET ABSPSPFL(NCPDPFLD)=""
- +36 IF ('$DATA(ABSPINCL(NCPDPFLD)))&&(SEGMENT="COUPON")&&('$DATA(ABSPSPSG(9)))
- SET ABSPSPFL(NCPDPFLD)=""
- +37 IF ('$DATA(ABSPINCL(NCPDPFLD)))&&(SEGMENT="COMPOUND")&&('$DATA(ABSPSPSG(10)))
- SET ABSPSPFL(NCPDPFLD)=""
- +38 IF ('$DATA(ABSPINCL(NCPDPFLD)))&&(SEGMENT="CLINICAL")&&('$DATA(ABSPSPSG(5)))
- SET ABSPSPFL(NCPDPFLD)=""
- +39 IF ('$DATA(ABSPINCL(NCPDPFLD)))&&(SEGMENT="PRIORAUTH")&&('$DATA(ABSPSPSG(12)))
- SET ABSPSPFL(NCPDPFLD)=""
- +40 IF ('$DATA(ABSPINCL(NCPDPFLD)))&&(SEGMENT="PROVIDER")&&('$DATA(ABSPSPSG(2)))
- SET ABSPSPFL(NCPDPFLD)=""
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +41 QUIT
- POPTOP(ABSPINS,ABSPBIN,ABSPPCN,ABSPMPD,ABSPVER,ABSPMAX,ABSPDISP,ABSPCONT,ABSPEXCL,ABSPHELP) ;Populate things that go on top level of Insurance
- +1 ; /IHS/OIT/RAM ; 9 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
- NEW INS,CURHELP,ZERR
- +2 SET CURHELP=$$GET1^DIQ(9002313.4,ABSPINS_",",100.05)
- +3 ;Don't over-write if they already have this field on the Insurer
- IF CURHELP=""
- SET INS(1,9002313.4,ABSPINS_",",100.05)=ABSPHELP
- +4 SET INS(1,9002313.4,ABSPINS_",",100.15)=ABSPVER
- +5 SET INS(1,9002313.4,ABSPINS_",",100.16)=ABSPBIN
- +6 SET INS(1,9002313.4,ABSPINS_",",100.17)=ABSPPCN
- +7 SET INS(1,9002313.4,ABSPINS_",",100.18)=ABSPMPD
- +8 SET INS(1,9002313.4,ABSPINS_",",100.19)=ABSPMAX
- +9 SET INS(1,9002313.4,ABSPINS_",",100.2)=ABSPDISP
- +10 SET INS(1,9002313.4,ABSPINS_",",100.3)=ABSPCONT
- +11 SET INS(1,9002313.4,ABSPINS_",",100.4)=ABSPEXCL
- +12 ; D UPDATE^DIE("E","INS(1)")
- +13 ; /IHS/OIT/RAM ; 9 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
- DO UPDATE^DIE("E","INS(1)",,"ZERR")
- +14 ; /IHS/OIT/RAM ; 9 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
- IF $DATA(ZERR)
- DO LOG^ABSPOSL2("POPTOP^ABSPICNV",.ZERR)
- +15 QUIT
- POPSPEC(ABSPINS,ABSPSPEC) ;Now populate the Special Code stuff
- +1 ; /IHS/OIT/RAM ; 9 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
- NEW NCPDPCD,INS,STRING,ZERR
- +2 SET NCPDPCD=""
- +3 FOR
- SET NCPDPCD=$ORDER(ABSPSPEC(NCPDPCD))
- IF NCPDPCD=""
- QUIT
- Begin DoDot:1
- +4 ;These are the fields that can't be overriden
- IF (NCPDPCD=111)!(NCPDPCD=103)
- QUIT
- +5 ;Fileman won't store this string with a ^ (caret) in it
- SET STRING=$TRANSLATE(ABSPSPEC(NCPDPCD),"^","|")
- +6 SET INS(1,9002313.42,"+1,"_ABSPINS_",",.01)=NCPDPCD
- +7 SET INS(1,9002313.42,"+1,"_ABSPINS_",",.02)=STRING
- +8 ; D UPDATE^DIE("E","INS(1)")
- +9 ; /IHS/OIT/RAM ; 9 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
- DO UPDATE^DIE("E","INS(1)",,"ZERR")
- +10 ; /IHS/OIT/RAM ; 9 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
- IF $DATA(ZERR)
- DO LOG^ABSPOSL2("POPSPEC^ABSPICNV",.ZERR)
- End DoDot:1
- +11 QUIT
- POPSEG(ABSPINS,ABSPSPSG) ;Next we populate the suppressed segments
- +1 ; /IHS/OIT/RAM ; 9 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
- NEW SEGCD,INS,ZERR
- +2 SET SEGCD=""
- +3 FOR
- SET SEGCD=$ORDER(ABSPSPSG(SEGCD))
- IF SEGCD=""
- QUIT
- Begin DoDot:1
- +4 SET INS(1,9002313.48,"+1,"_ABSPINS_",",.01)=SEGCD
- +5 ; D UPDATE^DIE("","INS(1)") ;On this one we are using the Internal value
- +6 ; /IHS/OIT/RAM ; 9 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
- DO UPDATE^DIE("","INS(1)",,"ZERR")
- +7 ; /IHS/OIT/RAM ; 9 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
- IF $DATA(ZERR)
- DO LOG^ABSPOSL2("POPSEG^ABSPICNV",.ZERR)
- End DoDot:1
- +8 QUIT
- POPFLD(ABSPINS,ABSPSPFL) ;Next we populate the suppressed fields
- +1 ; /IHS/OIT/RAM ; 9 JUN 17 ; ADD DBS CALL ERROR RETURN VARIABLE
- NEW NCPDPCD,ZERR
- +2 SET NCPDPCD=""
- +3 FOR
- SET NCPDPCD=$ORDER(ABSPSPFL(NCPDPCD))
- IF NCPDPCD=""
- QUIT
- Begin DoDot:1
- +4 SET INS(1,9002313.46,"+1,"_ABSPINS_",",.01)=NCPDPCD
- +5 ; D UPDATE^DIE("E","INS(1)")
- +6 ; /IHS/OIT/RAM ; 9 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
- DO UPDATE^DIE("E","INS(1)",,"ZERR")
- +7 ; /IHS/OIT/RAM ; 9 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
- IF $DATA(ZERR)
- DO LOG^ABSPOSL2("POPFLD^ABSPICNV",.ZERR)
- End DoDot:1
- +8 QUIT
- REVERSE +1 NEW ABSPINS,ABSPFMT
- +2 SET ABSPINS=0
- +3 FOR
- SET ABSPINS=$ORDER(^ABSPEI(ABSPINS))
- IF ABSPINS=""
- QUIT
- Begin DoDot:1
- +4 SET ABSPFMT=$PIECE($GET(^ABSPEI(ABSPINS,100)),U)
- +5 IF 'ABSPFMT
- QUIT
- +6 KILL ^ABSPEI(ABSPINS,210)
- +7 KILL ^ABSPEI(ABSPINS,220)
- +8 KILL ^ABSPEI(ABSPINS,221)
- End DoDot:1
- +9 ;This is how we know if this conversion has been run or not.
- SET ^ABSP(9002313.99,1,"ABSPICNV")=0
- +10 QUIT
