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

ACHSCONV.m

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