ACHSCONV ; IHS/ITSC/PMF -CHS CONVERT CHS DENIAL DATA FROM OLD TO NEW STRUCTURE ; [ 10/16/2001 8:16 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
;
S $ZT="ERROR"
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,$ZN,"ENTERED")=NOW
;
I '$G(CVERSION) S ^ACHSINST(ACHSVERS,$ZN,"CONVERSION NOT DONE, FIRST TIME INSTALL")=NOW Q
;
I +CVERSION>3 W !!,"THE CONVERSION OF 'CHS DENIAL DATA' FILE TO THE NEW DATA",!,"STRUCTURE HAS ALREADY BEEN PERFORMED!",!,"CONVERSION PROCESS WILL BE BYPASSED!" S ^ACHSINST(ACHSVERS,$ZN,"CONVERSION DID NOT TAKE PLACE")=NOW Q
;
;
D COPYG ;COPY EXISTING GLOBAL TO BACKUP GLOBAL
;
D CONV ;CONVERT EXISTING DATA TO NEW DATA STRUCTURE
;
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,$ZN,"FINISHED")=NOW
S ^ACHSINST(ACHSVERS,"CHS INSTALL","STATUS")="INSTALL FINISHED "_NOW
Q
;
COPYG ;
;COPY ACHSDEN TO ACHSDEN1
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,"COPYG^"_$ZN,"ENTERED")=NOW
;
M ^ACHSDEN1=^ACHSDEN
;
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,"COPYG^"_$ZN,"FINISHED")=NOW
Q
;
CONV ;CONVERT FROM OLD DATA STRUCTURE TO NEW
;
I '$D(^ACHSINST(ACHSVERS,"COPYG^"_$ZN,"FINISHED")) D Q
. W !!,"CONVERSION OF OLD DATA STRUCTURE ATTEMPTED WITHOUT OLD STRUCTURE BEING FINISHED!!"
. S ^ACHSINST(ACHSVERS,"ERROR",$ZN,"GLOBAL COPY OF ACHSDEN DID NOT FINISH")=NOW
. S ERROR=1,XPDABORT=1 D START^ACHSPOSM(ERROR)
. Q
;
I '$D(^ACHSDEN1) W !!,"COPY OF OLD DATA STRUCTURE NOT FOUND!!" S ^ACHSINST(ACHSVERS,"ERROR",$ZN,"ACHSDEN1 NOT FOUND")=NOW S ERROR=1,XPDABORT=1 D START^ACHSPOSM(ERROR) Q
;
;OKAY WE GOT A COPY OF THE OLD DATA LETS GO AHEAD
;
;ALLOW KILL OF ACHSDEN;TURN OFF 'NOKILL' GLOBAL CHARACTERISTIC
D CALL^%GCH("D","ACHSDEN","N")
;
;IF QF NOT = 0 PROBLEM;USUALLY DEVICE 63 WAS BUSY
I QF W !!,"PROBLEM TURNING OFF 'NOKILL' GLOBAL CHARACTERISTIC FOR ACHSDEN" S ^ACHSINST(ACHSVERS,"ERROR",$ZN,"PROBLEM TURNING OFF 'NOKILL' GLOBAL CHARACTERISTIC FOR ACHSDEN")=NOW S ERROR=1,XPDABORT=1 D START^ACHSPOSM(ERROR) Q
;
;kill the old data. SAC does not allow for a total global kill
S ^ACHSDEN="" F S ^ACHSDEN=$O(^ACHSDEN(^ACHSDEN)) Q:^ACHSDEN="" K ^ACHSDEN(^ACHSDEN)
;
K ^ACHSINST("INSURER FILE") ;RESET INSURER SEARCH
W !!,LINE
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,"CONV^"_$ZN,"ENTERED")=NOW
;
REDO S NUMENTRY=0
S STOP=0
S CM=","
;
S NODE="^ACHSDEN1"
F S NODE=$Q(@NODE) Q:NODE=""!(STOP) D
.;
.;SKIP X-REFS WE DO NOT NEED TO CONVERT THESE.
.S FIRSTSUB=$P($P(NODE,CM),"(",2)
.I FIRSTSUB?1""""1A.E1"""" S STOP=1 Q
.;
.;check for alpha subscripts, indicating a cross reference
.;do not process these
.S FOUND=0 F XXI=3:1:99 S XXS=$P($P(NODE,"(",2),CM,XXI) Q:XXS="" I XXS?1""""1A.E1"""" S FOUND=1 Q
.K XXI,XXS I FOUND Q
.K FOUND
.;
.;
.;CHECK FOR NEW DATA STRUCTURE MIXED WITH OLD AND SKIP
.I NODE[("""D""") D ASIS Q ;COPY AS IS
.I NODE[(",0)"),$L(NODE,",")=2 D REC0 Q
.I NODE[(",10)") D REC10 Q
.I NODE[(",100)") D REC100 Q
.I NODE[(",200,") D REC200 Q
.I NODE[(",210,") D REC210 Q
.I NODE[(",290)") D REC290 Q
.I NODE[(",300,") D REC300 Q
.I NODE[(",400)") D REC400 Q
.I NODE[(",500,") D REC500 Q
.I NODE[(",600,") D REC600 Q
.I NODE[(",650)") D REC650 Q
.I NODE[(",700,") D REC700 Q
;
S ^ACHSDEN(0)="CHS DENIAL DATA^9002071I"_U_$S($G(ISSUEFAC)="":0,1:ISSUEFAC)_U_$S($G(NUMENTRY)="":0,1:NUMENTRY)
;
;DO COUNTS OF FACILITIES AND ITEMS WITHIN FACILITY
S FAC=0 F CNT=1:1 S FAC=$O(^ACHSDEN(FAC)) Q:+FAC=0 D
.;S ^ACHSDEN(0)="CHS DENIAL DATA"_U_"9002071I"_U_FAC_U_CNT
.S ITEM=0 F CNT2=1:1 S ITEM=$O(^ACHSDEN(FAC,"D",ITEM)) Q:+ITEM=0 D
..S ^ACHSDEN(FAC,"D",0)=U_"9002071.01A"_U_ITEM_U_CNT2
;
W !!
W LINE
;
D REINDEX
;
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,"CONV^"_$ZN,"FINISHED")=NOW
;
Q
REINDEX ;REINDEX DENIAL DATA FILE
;
S %H=$H D YX^%DTC S NOW=Y
S ^ACHSINST(ACHSVERS,"REINDEX^"_$ZN,"ENTERED")=NOW
;
W !,"Re-indexing new Denial file..."
S DIK="^ACHSDEN("
D IXALL^DIK
S %H=$H D YX^%DTC S NOW=Y
W !,"Denial Updates Completed at ",$$FMTE^XLFDT(%)
;
S ^ACHSINST(ACHSVERS,"REINDEX^"_$ZN,"FINISHED")=NOW
;
Q
;
;COPY AS IS THIS IS THE NEW DATA STRUCTURE
ASIS ;
S RECORD=$G(@NODE)
S SUB1=$P(NODE,"(",2,299)
S ASISNODE="^ACHSDEN("_SUB1
S @ASISNODE=RECORD
;
Q
;GET THE ZERO NODE AND REARRANGE THE PIECES
REC0 ;
;
S NUMENTRY=NUMENTRY+1
S REC0=$G(@NODE)
S DENIAL=$P(REC0,U)
S ISSUEDT=$P(REC0,U,2)
S SERVDT=$P(REC0,U,3)
S ISREG=$P(REC0,U,4)
S PAT=$P(REC0,U,5)
S ISSUEBY=$P(REC0,U,6)
S REQDT=$P(REC0,U,7)
S ISSUEFAC=$P(REC0,U,8)
;
I ISSUEFAC="" D
. W !,"ISSUED BY FACILITY FIELD IS NULL!!"
. W !,"THE DENIAL #: ",DENIAL," SHOULD BE REVIEWED, FACILITY UNKNOWN!!"
. S ISSUEFAC="""UNKNOWN"""
I DENIAL[("#") D
. W !,"DENIAL PLACEHOLDER ",DENIAL," HAS BEEN CONVERTED"
. W !,"TO THE NEW FORMAT. YOU MAY WANT TO REVIEW THE ENTRY."
;
;
S ENTRYNUM=$P($P(NODE,","),"(",2)
;
;CHECK FOR EXISTING ENTRIES HERE (THIS SHOULD ONLY HAPPEN IN SITES WITH
;THE OLD STRUCTURE MIXED WITH THE NEW)
I $D(^ACHSDEN(ISSUEFAC,"D",ENTRYNUM)) W !,"ENTRY "_ENTRYNUM_" ALREADY EXISTS FOR THIS "_ISSUEFAC_"!" S ENTRYNUM=$O(^ACHSDEN(ISSUEFAC,"D","A"),-1)+1
;
S NEWNODE="^ACHSDEN("_ISSUEFAC
S @(NEWNODE_",0)")=ISSUEFAC
S NODE0=NEWNODE_",""D"","_ENTRYNUM_",0)"
S @NODE0=DENIAL_U_ISSUEDT_U_ISSUEBY_U_SERVDT_U_REQDT_U_ISREG_U_PAT
;
Q
REC10 ;EP
S REC10=$G(@NODE) ;NO CHANGE IN PIECES
S NODE10=NEWNODE_",""D"","_ENTRYNUM_",10)"
S @NODE10=REC10
Q
REC100 ;EP
S REC100=$G(@NODE) ;NO CHANGE IN PIECES
S NODE100=NEWNODE_",""D"","_ENTRYNUM_",100)"
S @NODE100=REC100
Q
REC200 ;EP
S REC200=$G(@NODE)
I $P(REC200,U,2)="9002071.01PA" S $P(REC200,U,2)="9002071.02PA"
S NODE200=NEWNODE_",""D"","_ENTRYNUM_",200"_$S(ENTRYNUM=200:$P(NODE,"200,200",2,99),1:$P(NODE,",200",2,99))
S @NODE200=REC200
Q
REC210 ;EP
S REC210=$G(@NODE) ;NO CHANGE IN PIECES
I $P(REC210,U,2)="9002071.05A" S $P(REC210,U,2)="9002071.03A"
S NODE210=NEWNODE_",""D"","_ENTRYNUM_",210"_$S(ENTRYNUM=210:$P(NODE,"210,210",2,99),1:$P(NODE,",210",2,99))
S @NODE210=REC210
Q
REC290 ;EP
;B
S REC290=$G(@NODE) ;CHANGE TO NODE 250 SAME PIECE
S NODE250=NEWNODE_",""D"","_ENTRYNUM_",250)"
S @NODE250=REC290
Q
REC300 ;EP
;B
S REC300=$G(@NODE) ;NO CHANGE IN PIECES
I $P(REC300,U,2)="9002071.02PA" S $P(REC300,U,2)="9002071.04PA"
S NODE300=NEWNODE_",""D"","_ENTRYNUM_",300"_$S(ENTRYNUM=300:$P(NODE,"300,300",2,99),1:$P(NODE,",300",2,99))
S @NODE300=REC300
Q
REC400 ;EP
S REC400=$G(@NODE) ;PIECES CHANGE
S DEFSER=$P(REC400,U)
S PRICAT=$P(REC400,U,4)
S MPRICAT=""
S:PRICAT'="" MPRICAT=$O(^ACHSMPRI("B",PRICAT,MPRICAT))
S APPEAL=$P(REC400,U,5)
S NREC400=DEFSER_U_MPRICAT_U_APPEAL
S NODE400=NEWNODE_",""D"","_ENTRYNUM_",400)"
S @NODE400=NREC400
Q
REC500 ;EP
S REC500=$G(@NODE)
I $P(REC500,U,2)="9002071.03PA" S $P(REC500,U,2)="9002071.05PA"
S NODE500=NEWNODE_",""D"","_ENTRYNUM_",500"_$S(ENTRYNUM=500:$P(NODE,"500,500",2,99),1:$P(NODE,",500",2,99))
S @NODE500=REC500
Q
REC600 ;EP
S REC600=$G(@NODE)
I $P(REC600,U,2)="9002071.04PA" S $P(REC600,U,2)="9002071.06PA"
S NODE600=NEWNODE_",""D"","_ENTRYNUM_",600"_$S(ENTRYNUM=600:$P(NODE,"600,600",2,99),1:$P(NODE,",600",2,99))
S @NODE600=REC600
Q
REC650 ;EP
S REC650=$G(@NODE)
S NODE500=NEWNODE_",""D"","_ENTRYNUM_",500,1,0)"
I $D(@NODE500) D
.S COM500=NEWNODE_",""D"","_ENTRYNUM_",500,1,1,0)"
.S COM500C=NEWNODE_",""D"","_ENTRYNUM_",500,1,1,1,0)"
.S @COM500=U_"9002071.53^1^1"
.S @COM500C=REC650
S NODE600=NEWNODE_",""D"","_ENTRYNUM_",600,1,0)"
I $D(@NODE600) D
.S COM600=NEWNODE_",""D"","_ENTRYNUM_",600,1,1,0)"
.S COM600C=NEWNODE_",""D"","_ENTRYNUM_",600,1,1,1,0)"
.S @COM600=U_"9002071.63^1^1"
.S @COM600C=REC650
;B
Q
REC700 ;EP
S REC700=$G(@NODE) ;CHANGE FROM 700 TO 800 FIELD GROUP
I $P(REC700,U,2)="9002071.06A" S $P(REC700,U,2)="9002071.08PA"
S NODE800=NEWNODE_",""D"","_ENTRYNUM_",800"_$S(ENTRYNUM=700:$P(NODE,"700,700",2,99),1:$P(NODE,",700",2,99))
S @NODE800=REC700
;OLD PIECE ONE IS A FREE TEXT ENTRY AND MUST BE CHANGED TO A POINTER
S OLDFREE=$P(@NODE800,U)
I $L(OLDFREE)<5 Q
D FINDINS(OLDFREE) ;FIND POSSIBLE INSURER USING OLD FREE TEXT ENTRY
;S OLDFREE="2131" ;***TPF TESTING
Q
;FIND POSSIBLE INSURER IN FILE INSURER^9999999.18
FINDINS(FREETEXT) ;
S NAME=""
F S NAME=$O(^AUTNINS("B",NAME)) Q:NAME="" D
.S INSPTR=$O(^AUTNINS("B",NAME,""))
.S:NAME[FREETEXT ^ACHSINST(ACHSVERS,"OTHER INSURER ENTRY FOR ","DOCUMENT "_DENIAL,"AND CONTAINS",NAME)=FREETEXT_U_"POSSIBLE POINTER VALUE="_INSPTR
.S:NAME=FREETEXT ^ACHSINST(ACHSVERS,"OTHER INSURER ENTRY FOR ","DOCUMENT "_DENIAL,"AND EQUALS",NAME)=FREETEXT_U_"POSSIBLE POINTER VALUE="_INSPTR
Q
;
ERROR S ^ACHSINST(ACHSVERS,"ERROR",$ZN,"ERROR TRAP CALLED")=NOW
S XPDABORT=1
G ^%ET
Q
;
ACHSCONV ; IHS/ITSC/PMF -CHS CONVERT CHS DENIAL DATA FROM OLD TO NEW STRUCTURE ; [ 10/16/2001 8:16 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
+2 ;
+3 SET $ZT="ERROR"
+4 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+5 SET ^ACHSINST(ACHSVERS,$ZN,"ENTERED")=NOW
+6 ;
+7 IF '$GET(CVERSION)
SET ^ACHSINST(ACHSVERS,$ZN,"CONVERSION NOT DONE, FIRST TIME INSTALL")=NOW
QUIT
+8 ;
+9 IF +CVERSION>3
WRITE !!,"THE CONVERSION OF 'CHS DENIAL DATA' FILE TO THE NEW DATA",!,"STRUCTURE HAS ALREADY BEEN PERFORMED!",!,"CONVERSION PROCESS WILL BE BYPASSED!"
SET ^ACHSINST(ACHSVERS,$ZN,"CONVERSION DID NOT TAKE PLACE")=NOW
QUIT
+10 ;
+11 ;
+12 ;COPY EXISTING GLOBAL TO BACKUP GLOBAL
DO COPYG
+13 ;
+14 ;CONVERT EXISTING DATA TO NEW DATA STRUCTURE
DO CONV
+15 ;
+16 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+17 SET ^ACHSINST(ACHSVERS,$ZN,"FINISHED")=NOW
+18 SET ^ACHSINST(ACHSVERS,"CHS INSTALL","STATUS")="INSTALL FINISHED "_NOW
+19 QUIT
+20 ;
COPYG ;
+1 ;COPY ACHSDEN TO ACHSDEN1
+2 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+3 SET ^ACHSINST(ACHSVERS,"COPYG^"_$ZN,"ENTERED")=NOW
+4 ;
+5 MERGE ^ACHSDEN1=^ACHSDEN
+6 ;
+7 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+8 SET ^ACHSINST(ACHSVERS,"COPYG^"_$ZN,"FINISHED")=NOW
+9 QUIT
+10 ;
CONV ;CONVERT FROM OLD DATA STRUCTURE TO NEW
+1 ;
+2 IF '$DATA(^ACHSINST(ACHSVERS,"COPYG^"_$ZN,"FINISHED"))
Begin DoDot:1
+3 WRITE !!,"CONVERSION OF OLD DATA STRUCTURE ATTEMPTED WITHOUT OLD STRUCTURE BEING FINISHED!!"
+4 SET ^ACHSINST(ACHSVERS,"ERROR",$ZN,"GLOBAL COPY OF ACHSDEN DID NOT FINISH")=NOW
+5 SET ERROR=1
SET XPDABORT=1
DO START^ACHSPOSM(ERROR)
+6 QUIT
End DoDot:1
QUIT
+7 ;
+8 IF '$DATA(^ACHSDEN1)
WRITE !!,"COPY OF OLD DATA STRUCTURE NOT FOUND!!"
SET ^ACHSINST(ACHSVERS,"ERROR",$ZN,"ACHSDEN1 NOT FOUND")=NOW
SET ERROR=1
SET XPDABORT=1
DO START^ACHSPOSM(ERROR)
QUIT
+9 ;
+10 ;OKAY WE GOT A COPY OF THE OLD DATA LETS GO AHEAD
+11 ;
+12 ;ALLOW KILL OF ACHSDEN;TURN OFF 'NOKILL' GLOBAL CHARACTERISTIC
+13 DO CALL^%GCH("D","ACHSDEN","N")
+14 ;
+15 ;IF QF NOT = 0 PROBLEM;USUALLY DEVICE 63 WAS BUSY
+16 IF QF
WRITE !!,"PROBLEM TURNING OFF 'NOKILL' GLOBAL CHARACTERISTIC FOR ACHSDEN"
SET ^ACHSINST(ACHSVERS,"ERROR",$ZN,"PROBLEM TURNING OFF 'NOKILL' GLOBAL CHARACTERISTIC FOR ACHSDEN")=NOW
SET ERROR=1
SET XPDABORT=1
DO START^ACHSPOSM(ERROR)
QUIT
+17 ;
+18 ;kill the old data. SAC does not allow for a total global kill
+19 SET ^ACHSDEN=""
FOR
SET ^ACHSDEN=$ORDER(^ACHSDEN(^ACHSDEN))
IF ^ACHSDEN=""
QUIT
KILL ^ACHSDEN(^ACHSDEN)
+20 ;
+21 ;RESET INSURER SEARCH
KILL ^ACHSINST("INSURER FILE")
+22 WRITE !!,LINE
+23 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+24 SET ^ACHSINST(ACHSVERS,"CONV^"_$ZN,"ENTERED")=NOW
+25 ;
REDO SET NUMENTRY=0
+1 SET STOP=0
+2 SET CM=","
+3 ;
+4 SET NODE="^ACHSDEN1"
+5 FOR
SET NODE=$QUERY(@NODE)
IF NODE=""!(STOP)
QUIT
Begin DoDot:1
+6 ;
+7 ;SKIP X-REFS WE DO NOT NEED TO CONVERT THESE.
+8 SET FIRSTSUB=$PIECE($PIECE(NODE,CM),"(",2)
+9 IF FIRSTSUB?1""""1A.E1""""
SET STOP=1
QUIT
+10 ;
+11 ;check for alpha subscripts, indicating a cross reference
+12 ;do not process these
+13 SET FOUND=0
FOR XXI=3:1:99
SET XXS=$PIECE($PIECE(NODE,"(",2),CM,XXI)
IF XXS=""
QUIT
IF XXS?1""""1A.E1""""
SET FOUND=1
QUIT
+14 KILL XXI,XXS
IF FOUND
QUIT
+15 KILL FOUND
+16 ;
+17 ;
+18 ;CHECK FOR NEW DATA STRUCTURE MIXED WITH OLD AND SKIP
+19 ;COPY AS IS
IF NODE[("""D""")
DO ASIS
QUIT
+20 IF NODE[(",0)")
IF $LENGTH(NODE,",")=2
DO REC0
QUIT
+21 IF NODE[(",10)")
DO REC10
QUIT
+22 IF NODE[(",100)")
DO REC100
QUIT
+23 IF NODE[(",200,")
DO REC200
QUIT
+24 IF NODE[(",210,")
DO REC210
QUIT
+25 IF NODE[(",290)")
DO REC290
QUIT
+26 IF NODE[(",300,")
DO REC300
QUIT
+27 IF NODE[(",400)")
DO REC400
QUIT
+28 IF NODE[(",500,")
DO REC500
QUIT
+29 IF NODE[(",600,")
DO REC600
QUIT
+30 IF NODE[(",650)")
DO REC650
QUIT
+31 IF NODE[(",700,")
DO REC700
QUIT
End DoDot:1
+32 ;
+33 SET ^ACHSDEN(0)="CHS DENIAL DATA^9002071I"_U_$SELECT($GET(ISSUEFAC)="":0,1:ISSUEFAC)_U_$SELECT($GET(NUMENTRY)="":0,1:NUMENTRY)
+34 ;
+35 ;DO COUNTS OF FACILITIES AND ITEMS WITHIN FACILITY
+36 SET FAC=0
FOR CNT=1:1
SET FAC=$ORDER(^ACHSDEN(FAC))
IF +FAC=0
QUIT
Begin DoDot:1
+37 ;S ^ACHSDEN(0)="CHS DENIAL DATA"_U_"9002071I"_U_FAC_U_CNT
+38 SET ITEM=0
FOR CNT2=1:1
SET ITEM=$ORDER(^ACHSDEN(FAC,"D",ITEM))
IF +ITEM=0
QUIT
Begin DoDot:2
+39 SET ^ACHSDEN(FAC,"D",0)=U_"9002071.01A"_U_ITEM_U_CNT2
End DoDot:2
End DoDot:1
+40 ;
+41 WRITE !!
+42 WRITE LINE
+43 ;
+44 DO REINDEX
+45 ;
+46 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+47 SET ^ACHSINST(ACHSVERS,"CONV^"_$ZN,"FINISHED")=NOW
+48 ;
+49 QUIT
REINDEX ;REINDEX DENIAL DATA FILE
+1 ;
+2 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+3 SET ^ACHSINST(ACHSVERS,"REINDEX^"_$ZN,"ENTERED")=NOW
+4 ;
+5 WRITE !,"Re-indexing new Denial file..."
+6 SET DIK="^ACHSDEN("
+7 DO IXALL^DIK
+8 SET %H=$HOROLOG
DO YX^%DTC
SET NOW=Y
+9 WRITE !,"Denial Updates Completed at ",$$FMTE^XLFDT(%)
+10 ;
+11 SET ^ACHSINST(ACHSVERS,"REINDEX^"_$ZN,"FINISHED")=NOW
+12 ;
+13 QUIT
+14 ;
+15 ;COPY AS IS THIS IS THE NEW DATA STRUCTURE
ASIS ;
+1 SET RECORD=$GET(@NODE)
+2 SET SUB1=$PIECE(NODE,"(",2,299)
+3 SET ASISNODE="^ACHSDEN("_SUB1
+4 SET @ASISNODE=RECORD
+5 ;
+6 QUIT
+7 ;GET THE ZERO NODE AND REARRANGE THE PIECES
REC0 ;
+1 ;
+2 SET NUMENTRY=NUMENTRY+1
+3 SET REC0=$GET(@NODE)
+4 SET DENIAL=$PIECE(REC0,U)
+5 SET ISSUEDT=$PIECE(REC0,U,2)
+6 SET SERVDT=$PIECE(REC0,U,3)
+7 SET ISREG=$PIECE(REC0,U,4)
+8 SET PAT=$PIECE(REC0,U,5)
+9 SET ISSUEBY=$PIECE(REC0,U,6)
+10 SET REQDT=$PIECE(REC0,U,7)
+11 SET ISSUEFAC=$PIECE(REC0,U,8)
+12 ;
+13 IF ISSUEFAC=""
Begin DoDot:1
+14 WRITE !,"ISSUED BY FACILITY FIELD IS NULL!!"
+15 WRITE !,"THE DENIAL #: ",DENIAL," SHOULD BE REVIEWED, FACILITY UNKNOWN!!"
+16 SET ISSUEFAC="""UNKNOWN"""
End DoDot:1
+17 IF DENIAL[("#")
Begin DoDot:1
+18 WRITE !,"DENIAL PLACEHOLDER ",DENIAL," HAS BEEN CONVERTED"
+19 WRITE !,"TO THE NEW FORMAT. YOU MAY WANT TO REVIEW THE ENTRY."
End DoDot:1
+20 ;
+21 ;
+22 SET ENTRYNUM=$PIECE($PIECE(NODE,","),"(",2)
+23 ;
+24 ;CHECK FOR EXISTING ENTRIES HERE (THIS SHOULD ONLY HAPPEN IN SITES WITH
+25 ;THE OLD STRUCTURE MIXED WITH THE NEW)
+26 IF $DATA(^ACHSDEN(ISSUEFAC,"D",ENTRYNUM))
WRITE !,"ENTRY "_ENTRYNUM_" ALREADY EXISTS FOR THIS "_ISSUEFAC_"!"
SET ENTRYNUM=$ORDER(^ACHSDEN(ISSUEFAC,"D","A"),-1)+1
+27 ;
+28 SET NEWNODE="^ACHSDEN("_ISSUEFAC
+29 SET @(NEWNODE_",0)")=ISSUEFAC
+30 SET NODE0=NEWNODE_",""D"","_ENTRYNUM_",0)"
+31 SET @NODE0=DENIAL_U_ISSUEDT_U_ISSUEBY_U_SERVDT_U_REQDT_U_ISREG_U_PAT
+32 ;
+33 QUIT
REC10 ;EP
+1 ;NO CHANGE IN PIECES
SET REC10=$GET(@NODE)
+2 SET NODE10=NEWNODE_",""D"","_ENTRYNUM_",10)"
+3 SET @NODE10=REC10
+4 QUIT
REC100 ;EP
+1 ;NO CHANGE IN PIECES
SET REC100=$GET(@NODE)
+2 SET NODE100=NEWNODE_",""D"","_ENTRYNUM_",100)"
+3 SET @NODE100=REC100
+4 QUIT
REC200 ;EP
+1 SET REC200=$GET(@NODE)
+2 IF $PIECE(REC200,U,2)="9002071.01PA"
SET $PIECE(REC200,U,2)="9002071.02PA"
+3 SET NODE200=NEWNODE_",""D"","_ENTRYNUM_",200"_$SELECT(ENTRYNUM=200:$PIECE(NODE,"200,200",2,99),1:$PIECE(NODE,",200",2,99))
+4 SET @NODE200=REC200
+5 QUIT
REC210 ;EP
+1 ;NO CHANGE IN PIECES
SET REC210=$GET(@NODE)
+2 IF $PIECE(REC210,U,2)="9002071.05A"
SET $PIECE(REC210,U,2)="9002071.03A"
+3 SET NODE210=NEWNODE_",""D"","_ENTRYNUM_",210"_$SELECT(ENTRYNUM=210:$PIECE(NODE,"210,210",2,99),1:$PIECE(NODE,",210",2,99))
+4 SET @NODE210=REC210
+5 QUIT
REC290 ;EP
+1 ;B
+2 ;CHANGE TO NODE 250 SAME PIECE
SET REC290=$GET(@NODE)
+3 SET NODE250=NEWNODE_",""D"","_ENTRYNUM_",250)"
+4 SET @NODE250=REC290
+5 QUIT
REC300 ;EP
+1 ;B
+2 ;NO CHANGE IN PIECES
SET REC300=$GET(@NODE)
+3 IF $PIECE(REC300,U,2)="9002071.02PA"
SET $PIECE(REC300,U,2)="9002071.04PA"
+4 SET NODE300=NEWNODE_",""D"","_ENTRYNUM_",300"_$SELECT(ENTRYNUM=300:$PIECE(NODE,"300,300",2,99),1:$PIECE(NODE,",300",2,99))
+5 SET @NODE300=REC300
+6 QUIT
REC400 ;EP
+1 ;PIECES CHANGE
SET REC400=$GET(@NODE)
+2 SET DEFSER=$PIECE(REC400,U)
+3 SET PRICAT=$PIECE(REC400,U,4)
+4 SET MPRICAT=""
+5 IF PRICAT'=""
SET MPRICAT=$ORDER(^ACHSMPRI("B",PRICAT,MPRICAT))
+6 SET APPEAL=$PIECE(REC400,U,5)
+7 SET NREC400=DEFSER_U_MPRICAT_U_APPEAL
+8 SET NODE400=NEWNODE_",""D"","_ENTRYNUM_",400)"
+9 SET @NODE400=NREC400
+10 QUIT
REC500 ;EP
+1 SET REC500=$GET(@NODE)
+2 IF $PIECE(REC500,U,2)="9002071.03PA"
SET $PIECE(REC500,U,2)="9002071.05PA"
+3 SET NODE500=NEWNODE_",""D"","_ENTRYNUM_",500"_$SELECT(ENTRYNUM=500:$PIECE(NODE,"500,500",2,99),1:$PIECE(NODE,",500",2,99))
+4 SET @NODE500=REC500
+5 QUIT
REC600 ;EP
+1 SET REC600=$GET(@NODE)
+2 IF $PIECE(REC600,U,2)="9002071.04PA"
SET $PIECE(REC600,U,2)="9002071.06PA"
+3 SET NODE600=NEWNODE_",""D"","_ENTRYNUM_",600"_$SELECT(ENTRYNUM=600:$PIECE(NODE,"600,600",2,99),1:$PIECE(NODE,",600",2,99))
+4 SET @NODE600=REC600
+5 QUIT
REC650 ;EP
+1 SET REC650=$GET(@NODE)
+2 SET NODE500=NEWNODE_",""D"","_ENTRYNUM_",500,1,0)"
+3 IF $DATA(@NODE500)
Begin DoDot:1
+4 SET COM500=NEWNODE_",""D"","_ENTRYNUM_",500,1,1,0)"
+5 SET COM500C=NEWNODE_",""D"","_ENTRYNUM_",500,1,1,1,0)"
+6 SET @COM500=U_"9002071.53^1^1"
+7 SET @COM500C=REC650
End DoDot:1
+8 SET NODE600=NEWNODE_",""D"","_ENTRYNUM_",600,1,0)"
+9 IF $DATA(@NODE600)
Begin DoDot:1
+10 SET COM600=NEWNODE_",""D"","_ENTRYNUM_",600,1,1,0)"
+11 SET COM600C=NEWNODE_",""D"","_ENTRYNUM_",600,1,1,1,0)"
+12 SET @COM600=U_"9002071.63^1^1"
+13 SET @COM600C=REC650
End DoDot:1
+14 ;B
+15 QUIT
REC700 ;EP
+1 ;CHANGE FROM 700 TO 800 FIELD GROUP
SET REC700=$GET(@NODE)
+2 IF $PIECE(REC700,U,2)="9002071.06A"
SET $PIECE(REC700,U,2)="9002071.08PA"
+3 SET NODE800=NEWNODE_",""D"","_ENTRYNUM_",800"_$SELECT(ENTRYNUM=700:$PIECE(NODE,"700,700",2,99),1:$PIECE(NODE,",700",2,99))
+4 SET @NODE800=REC700
+5 ;OLD PIECE ONE IS A FREE TEXT ENTRY AND MUST BE CHANGED TO A POINTER
+6 SET OLDFREE=$PIECE(@NODE800,U)
+7 IF $LENGTH(OLDFREE)<5
QUIT
+8 ;FIND POSSIBLE INSURER USING OLD FREE TEXT ENTRY
DO FINDINS(OLDFREE)
+9 ;S OLDFREE="2131" ;***TPF TESTING
+10 QUIT
+11 ;FIND POSSIBLE INSURER IN FILE INSURER^9999999.18
FINDINS(FREETEXT) ;
+1 SET NAME=""
+2 FOR
SET NAME=$ORDER(^AUTNINS("B",NAME))
IF NAME=""
QUIT
Begin DoDot:1
+3 SET INSPTR=$ORDER(^AUTNINS("B",NAME,""))
+4 IF NAME[FREETEXT
SET ^ACHSINST(ACHSVERS,"OTHER INSURER ENTRY FOR ","DOCUMENT "_DENIAL,"AND CONTAINS",NAME)=FREETEXT_U_"POSSIBLE POINTER VALUE="_INSPTR
+5 IF NAME=FREETEXT
SET ^ACHSINST(ACHSVERS,"OTHER INSURER ENTRY FOR ","DOCUMENT "_DENIAL,"AND EQUALS",NAME)=FREETEXT_U_"POSSIBLE POINTER VALUE="_INSPTR
End DoDot:1
+6 QUIT
+7 ;
ERROR SET ^ACHSINST(ACHSVERS,"ERROR",$ZN,"ERROR TRAP CALLED")=NOW
+1 SET XPDABORT=1
+2 GOTO ^%ET
+3 QUIT
+4 ;
