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
